subroutine prewgt(mype)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    prewgt
!   prgmmr: wu               org: np22                date: 2000-03-15
!
! abstract: setup smoothing and grid transform for background error
!
! program history log:
!   2000-03-15  wu
!   2004-02-03  kleist, updated to load background stats according
!               to updated mpi distribution on horizontal slabs
!   2004-03-15  derber, kleist, incorporate variances into this routine
!               stats from single file, additional clean up
!   2004-05-17  kleist, documentation and clean up
!   2004-08-03  treadon - add only to module use, add intent in/out
!   2004-10-26  wu - include factors hzscl in the range of RF table
!   2004-11-02  treadon - add horizontal resolution error check on berror_stats
!   2004-11-16  treadon - add longitude dimension to variance array dssv
!   2004-11-20  derber - modify to make horizontal table more reproducable and
!               move most of table calculations to berror
!   2005-01-22  parrish - split out balance variables to subroutine prebal--this
!               to make anisotropic filtering option less confusing
!   2005-02-23  wu - setup background variance for qoption=2
!   2005-03-28  wu - change loop index (mlat+1 to mlat) over varq
!   2005-04-14  treadon - add corq2 to global berror_stats read
!   2005-04-22  treadon - change berror file to 4-byte reals
!   2005-05-27  kleist - add setup call for new patch interpolation
!   2005-08-16  guo - add gmao surface interface
!   2005-09-28  guo - set nrr=nlat to support the GMAO grid
!   2005-09-28  guo - fixed nrr to nlat-2 to avoid the subscript of
!		array rlats being out of the range, and to avoid the
!		singularity of rs at rlats(1)=-pi/2.
!   2005-11-16  wgu - set nolp=nr+1+(ny-nlat)/2 to make sure
!               nmix+nrmxb=nr in routine smoothrf no matter what
!               number nlat is.
!   2005-11-29  derber - unify ozone variance calculation
!   2006-01-10  treadon - replace rdsfull with read_gfssfc_full
!   2006-01-11  kleist - place upper/lower bounds on qoption=2 variance
!   2006-01-31  treadon - invert hzscl
!   2006-02-03  derber - fix up sl array stuff
!   2006-04-12  treadon - remove sigl (not used)
!   2006-04-21  kleist  - add capability to perturb background error parameters
!   2006-07-28  derber  - use r1000 from constants
!   2006-09-18  derber  - change minimum moisture variance
!   2007-05-30  h.liu   - use oz stats from berror file
!   2007-07-03  kleist  - add option for flow-dependent background error variances
!   2008-04-23  safford - rm unused uses and vars
!   2008-07-30  guo     - read stats using m_berror_stats
!   2009-01-12  gayno   - rm use of read_gfssfc_full
!   2010-02-25  zhu     - mv varq to m_berror_stats
!                       - make changes for generalizing control variables,
!                         change interface of berror_read_wgt,use nrf*
!   2010-04-01  treadon - move strip to gridmod
!   2010-04-10  parrish - remove rhgues, no longer needed
!   2010-05-28  todling - obtain variable id's on the fly (add getindex)
!   2010-06-01  todling - bypass calculation when pointer not defined
!                         sort of generalize pert_berr
!                         rename as,tsfc_sdv to as3d,as2d,atsfc_sdv (alloc now)
!   2010-06-03  todling - protect motley in dssvs w/ mvars check
!                       - turn nrf2_loc/nrf3_loc into local variables
!   2010-06-18  todling - add call to write_bkgvars_grid and write_bkgvars2_grid
!   2010-07-07  kokron/todling - fix definition of hwllp to do sfc-only
!   2011-07-03  todling - calculation of bl and bl2 must be done in double-prec
!                         or GSI won'd work when running in single precision; go figure!
!   2012-05-14  wargan - add adjustozvar
!   2012-11-26  parrish - move subroutine blend to module blendmod.f90, and add "use blendmod, only: blend"
!   2012-12-15  zhu     - add two cwoption options
!   2013-10-19  todling - all guess variables in met-guess
!   2013-10-25  todling - reposition ltosi and others to commvars
!   2014-02-01  todling - update interface to berror_read_wgt
!   2014-02-05  mkim/todling - move cw overwrite w/ q to m_berror_stats
!   2014-08-02  zhu     - set up new background error variance and correlation lengths of cw
!                         for all-sky radiance assimilation
!   2020-07-14  todling- add adjustozhscl as optional
!
!   input argument list:
!     mype     - mpi task id
!
!   output argument list:
!
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,i_kind,r_single,r_double,r_quad
  use berror, only: dssvs,wtaxs,&
       bw,wtxrs,inaxs,inxrs,nr,ny,nx,mr,ndeg,&
       nf,vs,be,dssv,norh,bl2,bl,init_rftable,hzscl,&
       pert_berr,bkgv_flowdep,slw,slw1,slw2,bkgv_write,nhscrf,&
       adjustozvar,adjustozhscl
  use m_berror_stats,only : berror_read_wgt
  use mpimod, only: nvar_id,levs_id
  use mpimod, only: mpi_comm_world,ierror,mpi_rtype
  use jfunc, only: varcw,cwoption
  use jfunc, only: varq,qoption
  use control_vectors, only: cvars2d,cvars3d
  use control_vectors, only: cvars => nrf_var
  use control_vectors, only: as2d,as3d,atsfc_sdv
  use control_vectors, only: nrf,nc2d,nc3d,mvars
  use gridmod, only: istart,jstart,lat2,lon2,rlats,nlat,nlon,nsig,&
       nnnn1o,lat1,lon1,itotsub,iglobal,ijn,displs_g,&
       strip
  use general_commvars_mod, only: ltosi,ltosj
  use constants, only: zero,quarter,half,one,two,three,&
       rearth_equator,pi,r1000,r400
  use guess_grids, only: isli2
  use guess_grids, only: ntguessig
  use smooth_polcarf, only: norsp,setup_smooth_polcas
  use mpeu_util, only: getindex
  use blendmod, only: blend
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use gsi_metguess_mod, only: gsi_metguess_bundle

  implicit none

! Declare passed variables
  integer(i_kind),intent(in   ) :: mype

! Declare local variables
  integer(i_kind) n,nrr,iii,jjj,nxg,i2,im,jm,j2
  integer(i_kind) i,j,k,ii,nn,nbuf,nmix,nxe,nor,ndx,ndy
  integer(i_kind) nlathh,mm1,nolp,mm,ir,k1
  integer(i_kind) ix,jx,mlat
  integer(i_kind) nf2p,istatus
  integer(i_kind),dimension(0:40):: iblend
  integer(i_kind) nrf3_sf,nrf3_q,nrf3_vp,nrf3_t,nrf3_oz,nrf2_ps,nrf2_sst,nrf3_cw
  integer(i_kind),allocatable,dimension(:) :: nrf3_loc,nrf2_loc

  real(r_kind) wlipi,wlipih,df
  real(r_kind) samp,s2u,df2,pi2
  real(r_quad) y,x,dxx
  real(r_kind),dimension(ndeg):: rate
  real(r_kind),dimension(ndeg,ndeg):: turn
  real(r_kind),dimension(lat2,lon2)::temp
  real(r_kind),dimension(nlat,nlon):: sl,factx
  real(r_kind),dimension(-nf:nf,-nf:nf) :: fact1,fact2
  real(r_kind),dimension(mr:nlat-2):: rs
  real(r_kind),dimension(lat1*lon1)::zsm
  real(r_kind),dimension(itotsub)::work1
  real(r_kind),dimension(ny,nx,3):: scsli
  real(r_kind),dimension(-nf:nf,-nf:nf,3):: scs12
  real(r_single),dimension(nlat,nlon):: corsst
  real(r_kind),dimension(lon2,nsig):: dsv
  real(r_single) hsstmin
  real(r_kind) minhsst
  real(r_kind) my_corz
  real(r_kind),allocatable:: randfct(:)
  real(r_kind),allocatable,dimension(:,:,:,:):: sli,sli1,sli2

  real(r_kind),allocatable,dimension(:,:,:):: vz
  real(r_kind),allocatable,dimension(:,:,:):: hwll
  real(r_kind),allocatable,dimension(:,:)  :: hwllp

  real(r_single),allocatable,dimension(:,:,:):: corz
  real(r_single),allocatable,dimension(:,:,:):: hwllin
  real(r_single),allocatable,dimension(:,:,:):: vscalesin
  real(r_single),allocatable,dimension(:,:)  :: corp
  real(r_single),allocatable,dimension(:,:)  :: hwllinp
  real(r_single),allocatable,dimension(:,:)  :: hsst

  real(r_kind),dimension(lat2,lon2,nsig):: sfvar,vpvar,tvar
  real(r_kind),dimension(lat2,lon2):: psvar
  real(r_kind),dimension(:,:,:),pointer :: ges_oz=>NULL()
! real(r_kind),parameter:: eight_tenths = 0.8_r_kind
! real(r_kind),parameter:: six          = 6.0_r_kind
! real(r_kind),parameter:: r800         = 800.0_r_kind
! real(r_kind),parameter:: r40000       = 40000.0_r_kind
! real(r_kind),parameter:: r25          = one/25.0_r_kind

! Initialize local variables
  pi2=two*pi
  ndy=(nlat-ny)/2
  nxe=nlon/8
  nor=norh*2
  mm1=mype+1
  nlathh=nlat/4
  nf2p=2*nf+1

  if(nc2d>0) then
     allocate(hwllp(0:nlat+1,nc2d))
     allocate(corp(nlat,nc2d))
     allocate(hwllinp(nlat,nc2d))
     hwllp=zero
  endif

  if(nc3d>0)then
     allocate(vz(nsig,0:nlat+1,nc3d))
     allocate(hwll(0:nlat+1,nsig,nc3d))
     allocate(corz(nlat,nsig,nc3d))
     allocate(hwllin(nlat,nsig,nc3d))
     allocate(vscalesin(nsig,nlat,nc3d))
  endif

  allocate(hsst(nlat,nlon))

! Get indexes to required CV variables
  nrf3_oz   = getindex(cvars3d,'oz')
  nrf3_t    = getindex(cvars3d,'t')
  nrf3_sf   = getindex(cvars3d,'sf')
  nrf3_vp   = getindex(cvars3d,'vp')
  nrf3_q    = getindex(cvars3d,'q')
  nrf3_cw   = getindex(cvars3d,'cw')
  nrf2_ps   = getindex(cvars2d,'ps')
  nrf2_sst  = getindex(cvars2d,'sst')
! nrf2_stl  = getindex(cvarsmd,'stl')
! nrf2_sti  = getindex(cvarsmd,'sti')

! Setup blending
  mm=4
  call blend(mm,iblend)

  nolp=nr+1+(ny-nlat)/2
!  nbuf=nolp/4
  nbuf=0
  nmix=nolp-nbuf*2
  dxx=1._r_quad/real((nmix+1),r_quad)
  bl2=0._r_kind
  k=0
  do i=1,nmix
     k=k+1
     x=i*dxx
     y=0._r_quad
     y=real(iblend(mm),r_quad)
     do j=mm-1,0,-1
        y=x*y+real(iblend(j),r_quad)
     enddo
     y=y*x**(mm+1)
     bl2(k)=1._r_quad-y
  enddo
  if(minval(bl2)<zero) then
     write(6,*) 'prewgt: trouble bl2 coeffs negative ', bl2
     call stop2(99)
  endif
  do k=1,nmix
    bl2(k)=sqrt(bl2(k))
  end do

! Modify precision to be consistent with bl2 for higher res grids
! ** NOTE ** bl and bl2 are actually defined to be r_kind
!
  nmix=(nx-nlon)
  dxx=1._r_quad/real((nmix+1),r_quad)
  ndx=(nx-nlon)
  bl=0._r_kind
  k=ndx-nmix
  do i=1,nmix
     k=k+1
     x=real(i,r_quad)*dxx
     y=0._r_quad
     y=real(iblend(mm),r_quad)
     do j=mm-1,0,-1
        y=x*y+real(iblend(j),r_quad)
     enddo
     y=y*x**real((mm+1),r_quad)
     bl(k)=1._r_quad-y
  enddo

  if(minval(bl)<zero) then
     write(6,*) 'prewgt: trouble bl coeffs negative ', bl
     call stop2(99)
  endif
  do k=1,nmix
     bl(k)=sqrt(bl(k))
  end do

! Setup sea-land mask
  sl=zero
  if(bw /= zero)then
    do j=1,lon1*lat1
       zsm(j)=zero
     end do
     do j=1,lon2
        do i=1,lat2
           temp(i,j)=float(isli2(i,j))
        end do
     end do

     call strip(temp,zsm)

     call mpi_allgatherv(zsm,ijn(mm1),mpi_rtype,&
        work1,ijn,displs_g,mpi_rtype,&
        mpi_comm_world,ierror)

     do k=1,iglobal
        i=ltosi(k) ; j=ltosj(k)
        sl(i,j)=work1(k)
     end do

     do j=1,nlon
        do i=1,nlat
           if(sl(i,j) > one)sl(i,j)=zero
        enddo
     enddo
     call smoothww(nlat,nlon,sl,half,2,1)
     do j=1,nlon
        do i=1,nlat
           sl(i,j)=min(max(sl(i,j),zero),one)
        enddo
     enddo
  end if

! Get background error statistics from a file ("berror_stats").
  call berror_read_wgt(corz,corp,hwllin,hwllinp,vscalesin,corsst,hsst,varq,qoption,varcw,cwoption,mype)
  mlat=nlat

! load the horizontal length scales
  hwll=zero
  do j=1,nc3d
     do k=1,nsig
        do i=1,nlat
           hwll(i,k,j)=hwllin(i,k,j)
        end do
     end do
  end do
  if(nrf3_oz>0.and.adjustozhscl>zero) hwll(:,:,nrf3_oz)=hwll(:,:,nrf3_oz)*adjustozhscl   !inflate scale

! surface pressure
  if(nrf2_ps>0) then
     do i=1,nlat
        hwllp(i,nrf2_ps)=hwllinp(i,nrf2_ps)
     end do
  endif

! sea surface temperature, convert from km to m
! also calculate a minimum horizontal length scale for
! sst to be used for land skin temp and ice temp
  hsstmin=1.e10_r_single
  minhsst=1.e10_r_kind
  do j=1,nlon
     do i=1,nlat
        hsst(i,j)=r1000*hsst(i,j)
        hsstmin=min(hsstmin,hsst(i,j))
     end do
  end do
  minhsst=hsstmin

! perturb background error
! Things to perturb: as(1-8), hzscl(1-3) and vs(1)
  if (pert_berr) then
     allocate(randfct(nc2d+nc3d+3+1))

     call get_randoms(nc2d+nc3d+3+1,randfct)
     do i=1,nc3d
        as3d(i)=as3d(i)+as3d(i)*randfct(i)
     end do
     ii=nc3d
     do i=1,nc2d
        ii=ii+1
        as2d(i)=as2d(i)+as2d(i)*randfct(ii)
     end do
     do i=1,nhscrf
        hzscl(i)=hzscl(i)+hzscl(i)*randfct(nc2d+nc3d+i)
     end do
     vs=vs+vs*randfct(nc2d+nc3d+3+1)
     if (mype==0) then
        write(6,*) 'PREWGT: REDEFINE AS = ',as3d,as2d
        write(6,*) 'PREWGT: REDEFINE HZSCL = ',hzscl
        write(6,*) 'PREWGT: REDEFINE VS = ',vs
     end if
     deallocate(randfct)
  end if

! As used in the code, the horizontal length scale
! parameters are used in an inverted form.  Invert
! the parameter values here.
  do i=1,nhscrf
     hzscl(i)=one/hzscl(i)
  end do
! apply scaling (deflate/inflate) to vertical length scales
! note: parameter vs needs to be inverted
  vs=one/vs

! Initialize full array to zero before loading part of array below
  vz=zero

! load vertical length scales
  do j=1,nc3d
     do k=1,nsig
        do i=1,nlat
           vz(k,i,j)=vs*vscalesin(k,i,j)
        end do
     end do
  end do

  call rfdpar1(be,rate,ndeg)
  call rfdpar2(be,rate,turn,samp,ndeg)

! Load background error variances onto subdomains
  if(nrf3_sf>0.and.nrf3_vp>0) then
     do k=1,nsig
        do i=1,lat2
           ix=istart(mm1)+i-2
           ix=max(ix,2)
           ix=min(nlat-1,ix)
           do j=1,lon2
              sfvar(i,j,k)=corz(ix,k,nrf3_sf)
              vpvar(i,j,k)=corz(ix,k,nrf3_vp)
           end do
        end do
     end do
  end if
  if(nrf3_t>0) then
     do k=1,nsig
        do i=1,lat2
           ix=istart(mm1)+i-2
           ix=max(ix,2)
           ix=min(nlat-1,ix)
           do j=1,lon2
              tvar(i,j,k)=corz(ix,k,nrf3_t)
           end do
        end do
     end do
  end if

  if(nrf2_ps>0) then
     do i=1,lat2
        ix=istart(mm1)+i-2
        ix=max(ix,2)
        ix=min(nlat-1,ix)
        do j=1,lon2
           psvar(i,j)=corp(ix,nrf2_ps)
        end do
     end do
  end if

! Reweight the variances based on flow dependence if flag set
  if (bkgv_flowdep) then
      call bkgvar_rewgt(sfvar,vpvar,tvar,psvar,mype)
  else
      if (bkgv_write) call write_bkgvars_grid(sfvar,vpvar,tvar,psvar,mype)
  endif

! vertical length scales
!!!$omp parallel do  schedule(dynamic,1) private(i,n,k,j,jx,ix,loc,dsv)
  do n=1,nc3d
     do j=1,lat2
        jx=istart(mm1)+j-2
        jx=max(jx,2)
        jx=min(nlat-1,jx)
        call smoothzo(vz(1,jx,n),samp,rate,n,j,dsv)

!       load variances onto subdomains
        if (n==nrf3_sf) then
           do k=1,nsig
              do i=1,lon2
                 dssv(j,i,k,n)=dsv(i,k)*sfvar(j,i,k)*as3d(n)   ! streamfunction
              end do
           end do
        else if (n==nrf3_vp) then
           do k=1,nsig
              do i=1,lon2
                 dssv(j,i,k,n)=dsv(i,k)*vpvar(j,i,k)*as3d(n)   ! velocity potential
              end do
           end do
        else if (n==nrf3_t) then
           do k=1,nsig
              do i=1,lon2
                 dssv(j,i,k,n)=dsv(i,k)*tvar(j,i,k)*as3d(n)    ! temperature
              end do
           end do
        else if (n==nrf3_oz.and.adjustozvar) then
           call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'oz',ges_oz,istatus)
           if (istatus==0) then
              do k=1,nsig
                 do i=1,lon2
                    my_corz = max(ges_oz(j,i,k),0.000000002_r_kind)
                    ! Reduce weight in the stratosphere
                    if (my_corz .gt. 0.0000001_r_kind) my_corz = my_corz/4.0
                    dssv(j,i,k,n)=dsv(i,k)*my_corz*as3d(n)   ! ozone
                 end do
              end do
           endif
        else
           do k=1,nsig
              do i=1,lon2
                 dssv(j,i,k,n)=dsv(i,k)*corz(jx,k,n)*as3d(n)
              end do
           end do
        end if
    enddo
  end do

! Special case of dssv for qoption=2 and cw
  if (qoption==2) call compute_qvar3d

!!!$omp parallel do  schedule(dynamic,1) private(i,n,j,jx,ix,loc)
  do n=1,nc2d
     if (n==nrf2_ps) then
        do j=1,lat2
           do i=1,lon2
              dssvs(j,i,n)=psvar(j,i)*as2d(n)             ! surface pressure
           end do
        end do
     else if (n==nrf2_sst) then
        do j=1,lat2
           do i=1,lon2
              if(mvars>=2 .and. isli2(j,i)==1)then
                 dssvs(j,i,nc2d+1)= atsfc_sdv(1)          ! land surface temperature
              else if(mvars>=2 .and. isli2(j,i)==2)then
                 dssvs(j,i,nc2d+2)= atsfc_sdv(2)          ! ice surface temperature
              else
                 jx=istart(mm1)+j-2
                 jx=max(jx,2)
                 jx=min(nlat-1,jx)
                 ix=jstart(mm1)+i-2
                 if (ix==0) ix=nlon
                 ix=max(ix,1)
                 if (ix==nlon+1) ix=1
                 ix=min(nlon,ix)
                 dssvs(j,i,n)=corsst(jx,ix)*as2d(n)        ! sea surface temperature
              end if
           end do
        end do
     end if
  end do

  if (bkgv_write) call write_bkgvars2_grid

! distance of gaussian lat from pole on stereogaphic map
! r=r/(1+z)
  do ir=mr,ubound(rs,1)		! ubound(rs,1) is nlat-2 to skip S.P.
     rs(ir)=cos(rlats(nlat-ir))/(one+sin(rlats(nlat-ir)))
  enddo
  df=tan(pi2/nlon*half)

! set up polcas
  call setwts(wtaxs,wtxrs,inaxs,inxrs,rs,df,nor,nxe,nf,mr,nr)

! set up smooth_polcas if desired (norsp > 0)
  if(norsp>0) call setup_smooth_polcas

! load arrays which are in correct units, to be used to
! define the scales below
  do j=1,nlon
     do i=2,nlat-1
        factx(i,j)=one/(one+(one-sl(i,j))*bw)
     end do
     factx(1,j)=factx(2,j)
     factx(nlat,j)=factx(nlat-1,j)
  end do

  wlipi=nlon/pi2
  wlipih=nlon/pi2*half*samp*samp
  do j=1,nx
     jjj=j-ndx
     if(jjj<1)jjj=nlon+jjj
     if(jjj>nlon)jjj=jjj-nlon
     do i=1,ny
        iii=i+ndy
        scsli(i,j,1)=(rlats(iii+1)-rlats(iii-1))*wlipih*cos(rlats(iii))* &
                     factx(iii,jjj)**2
        scsli(i,j,2)=(rlats(iii     )-rlats(iii-1))*wlipi*factx(iii,jjj)
        scsli(i,j,3)=cos(rlats(iii))*factx(iii,jjj)
     enddo
  enddo

  nxg=nxe+norh
  nrr=ubound(rs,1)	! was nf*3/2
  ndx=(nx-nlon)/2
  call polcasl(factx,fact1,fact2,1,nf,mr,nrr,nor,rs,df,nxe,nxg)
  fact1(0,0)=quarter*(fact1(1,0)+fact1(0,1)+fact1(-1,0)+fact1(0,-1))
  fact2(0,0)=quarter*(fact2(1,0)+fact2(0,1)+fact2(-1,0)+fact2(0,-1))

  df2=df*df
  do j=-nf,nf
     jm=j-1
     j2=j*j
     do i=-nf,nf
        im=i-1
        i2=i*i
        scs12(i,j,1)=(samp/(one+(i2+j2)*df2))**2*fact1(i,j)**2
        scs12(i,j,2)=one/(one+((im*im+i2)*half+j2)*df2)*fact1(i,j)
        scs12(i,j,3)=one/(one+(i2+(j2+jm*jm)*half)*df2)*fact1(i,j)
     enddo
  enddo

! Convert horizontal scales from physical units (m) to grid relative units
! rearth_equator is the equatorial radius from a 1999 IAG report.  The
! horizontal scales are defined at the equator, hence the need for the
! equatorial radius.
  s2u=(two*pi*rearth_equator)/float(nlon)

  allocate(sli(ny,nx,2,nnnn1o),sli1(-nf:nf,-nf:nf,2,nnnn1o), &
                               sli2(-nf:nf,-nf:nf,2,nnnn1o))

  allocate(nrf3_loc(nc3d),nrf2_loc(nc2d))
  do ii=1,nc3d
     nrf3_loc(ii)=getindex(cvars,cvars3d(ii))
  enddo
  do ii=1,nc2d
     nrf2_loc(ii)=getindex(cvars,cvars2d(ii))
  enddo

!!!$omp parallel do  schedule(dynamic,1) private(k,k1,j,ii,iii,jjj,i,n,nn,factx,fact1,fact2)
  do k=1,nnnn1o
     k1=levs_id(k)
     if (k1==0) then
        do j=1,nlon
           do i=2,nlat-1
              factx(i,j)=zero
           end do
        end do
     else
        n=nvar_id(k)
        nn=-1
        do ii=1,nc3d
           if (nrf3_loc(ii)==n) then
              nn=ii
              do j=1,nlon
                 do i=2,nlat-1
                    factx(i,j)=s2u/hwll(i,k1,nn)
                 end do
              end do
              exit
           end if
        end do

        if (nn==-1) then
           do ii=1,nc2d
              if (nrf2_loc(ii)==n .or. n>nrf) then
                 nn=ii
                 if (n>nrf) nn=n-nc3d
                 if (nn==nrf2_sst) then
                    do j=1,nlon
                       do i=2,nlat-1
                          factx(i,j)=s2u/hsst(i,j)
                       end do
                    end do
                 else if (nn>nc2d) then
                    do j=1,nlon
                       do i=2,nlat-1
                          factx(i,j)=two*s2u/minhsst
                       end do
                    end do
                 else
                    do j=1,nlon
                       do i=2,nlat-1
                          factx(i,j)=s2u/hwllp(i,nn)
                       end do
                    end do
                 end if
                 exit
              end if
           end do
        end if
     endif    ! end if over nvar_id
     do j=1,nlon
        factx(1,j)=factx(2,j)
        factx(nlat,j)=factx(nlat-1,j)
     end do

     call polcasl(factx,fact1,fact2,1,nf,mr,nrr,nor,rs,df,nxe,nxg)
     fact1(0,0)=quarter*(fact1(1,0)+fact1(0,1)+fact1(-1,0)+fact1(0,-1))
     fact2(0,0)=quarter*(fact2(1,0)+fact2(0,1)+fact2(-1,0)+fact2(0,-1))
! first sli
     do j=1,nx
        jjj=j-ndx
        if(jjj < 1)jjj=jjj+nlon
        if(jjj > nlon)jjj=jjj-nlon
        do i=1,ny
           iii=i+ndy
           slw((j-1)*ny+i,k)=scsli(i,j,1)*factx(iii,jjj)**2
           sli(i,j,1,k)=scsli(i,j,2)*factx(iii,jjj)
           sli(i,j,2,k)=scsli(i,j,3)*factx(iii,jjj)
        enddo
     enddo
! now load sli1/sli2
     do j=-nf,nf
        do i=-nf,nf
           slw2((j+nf)*nf2p+nf+1+i,k)=scs12(i,j,1)*fact1(i,j)**2
           slw1((j+nf)*nf2p+nf+1+i,k)=scs12(i,j,1)*fact2(i,j)**2
           sli2(i,j,1,k)=scs12(i,j,2)*fact1(i,j)
           sli1(i,j,1,k)=scs12(i,j,2)*fact2(i,j)
           sli2(i,j,2,k)=scs12(i,j,3)*fact1(i,j)
           sli1(i,j,2,k)=scs12(i,j,3)*fact2(i,j)
        enddo
     enddo
  end do ! end do over nsig1o/loadling of sli arrays

  deallocate(nrf3_loc,nrf2_loc)

! Load tables used in recursive filters
  call init_rftable(mype,rate,nnnn1o,sli,sli1,sli2)

! Clean up: first-in, last-out
  deallocate(sli,sli1,sli2)
  deallocate(hsst)

  if(allocated(vscalesin)) deallocate(vscalesin)
  if(allocated(hwllin))    deallocate(hwllin)
  if(allocated(corz))      deallocate(corz)
  if(allocated(hwll))      deallocate(hwll)
  if(allocated(vz))        deallocate(vz)

  if(allocated(hwllinp)) deallocate(hwllinp)
  if(allocated(corp))    deallocate(corp)
  if(allocated(hwllp))   deallocate(hwllp)

  return
end subroutine prewgt

subroutine get_randoms(count,randnums)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    get_randoms
!   prgmmr: kleist           org: np22              date: 2006-04-24
!
! abstract: get random numbers for perturbing background error parms
!
! program history log:
!   2006-04-21  kleist
!   2008-04-23  safford - rm unused uses
!
!   input argument list:
!     count    - number or random numbers to generate
!
!   output argument list:
!     randnums - array of scaled random numbers
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$

  use kinds, only: r_kind,i_kind
  use obsmod, only: iadate
  use berror, only: pert_berr_fct
  use constants, only: one, two
  implicit none

  integer(i_kind)              ,intent(in   ) :: count
  real(r_kind),dimension(count),intent(  out) :: randnums

  integer(i_kind),allocatable,dimension(:):: numrnds
  real(r_kind),dimension(count+1):: temps
  real(r_kind):: rseed

  integer(i_kind) i,ksize

  call random_seed(size=ksize)
  allocate(numrnds(ksize))

! set seed as a function of analysis date
  rseed = 1e6_r_kind*iadate(1) + 1e4_r_kind*iadate(2) &
       + 1e2_r_kind*iadate(3) + iadate(4)

  do i=1,ksize
     numrnds(i)=rseed
  end do

  call random_seed(put=numrnds)
  deallocate(numrnds)

! this goes from 0-1, but want -1 to 1
  call random_number(temps)

! Set range to be +/- factor
! and don't use first random number generated based on date
  do i=1,count
     randnums(i) = pert_berr_fct*(one - two*temps(i+1))
  end do

  return
end subroutine get_randoms


#include "../defines.inc"
!--------------------------------------------------------------*
!
!           Makes Monti Carlo Moves
!
!    Quinn split out this file on 8/9/17
!
!---------------------------------------------------------------

! variables that need to be allocated only on certain branches moved into MD to prevent segfaults
! please move other variables in as you see fit
subroutine mc_slide(IB1, IB2, IT1, IT2, MCAMP, WindoW, rand_stat, dib, success)
! values from wlcsim_data
   use params, only: wlc_RP, wlc_R, wlc_U, wlc_VP, wlc_V, wlc_UP, &
                     wlc_nBend, wlc_bendPoints, wlc_pointsMoved, wlc_nPointsMoved, &
                     wlc_ExplicitBindingPair, wlc_network_start_index, wlc_other_beads

   use mersenne_twister
   use params, only: dp
   use windowTools, only: draw_window
   use polydispersity, only: is_right_end, is_left_end, first_bead_of_chain, last_bead_of_chain, length_of_chain
   use ringHelper, only: bend_points_left_ring, bend_points_right_ring, &
                         points_moved_left_ring, points_moved_right_ring

   implicit none
   integer, intent(out) :: IB1   ! Test bead position 1
   integer, intent(out) :: IT1   ! Index of test bead 1
   integer, intent(out) :: IB2   ! Test bead position 2
   integer, intent(out) :: IT2   ! Index of test bead 2
   integer, intent(out) :: dib   ! number of beads moved by move (plus or minus a few)
   logical, intent(out) :: success

   integer IP    ! Test polymer
   integer I, J  ! Test indices
   integer ii
   integer otherEnd
! Things for random number generator
   type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
   real(dp) urand(3)  ! random vector
   real(dp), intent(in) :: MCAMP ! Amplitude of random change
!integer, intent(in) :: WLC_P__WINTYPE
   real(dp), intent(in) :: WindoW ! Size of window for bead selection
   real(dp) DR(3)    ! Displacement for slide move
   integer indx
   logical duplicates

!     Perform slide move (MCTYPE 2)
   call draw_window(window, WLC_P__MAXWINDOW_SLIDE_MOVE, .false., rand_stat, &
                    IT1, IT2, IB1, IB2, IP, DIB, success)

   call random_number(urand, rand_stat)
   DR(1) = MCAMP*(urand(1) - 0.5_dp)
   DR(2) = MCAMP*(urand(2) - 0.5_dp)
   DR(3) = MCAMP*(urand(3) - 0.5_dp)

!  Which elastic segments change
   wlc_nBend = 0
   if (.not. WLC_P__RING) then                 ! polymer is not a ring
      if (IB1 > 1) then
         wlc_nBend = wlc_nBend + 1
         wlc_bendPoints(wlc_nBend) = IT1 - 1
         I = IT1 - 1
         wlc_RP(:, I) = wlc_R(:, I)
         wlc_UP(:, I) = wlc_U(:, I)
         if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
         wlc_nPointsMoved = wlc_nPointsMoved + 1
         wlc_pointsMoved(wlc_nPointsMoved) = I
      endif
      if (IB2 < length_of_chain(IP)) then
         wlc_nBend = wlc_nBend + 1
         wlc_bendPoints(wlc_nBend) = IT2
         I = IT2 + 1
         wlc_RP(:, I) = wlc_R(:, I)
         wlc_UP(:, I) = wlc_U(:, I)
         if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
         wlc_nPointsMoved = wlc_nPointsMoved + 1
         wlc_pointsMoved(wlc_nPointsMoved) = I
      endif
   else                                        ! polymer is a ring
      if (length_of_chain(IP) - DIB > 2) then
         call bend_points_left_ring(IT1)
         call points_moved_left_ring(IT1)
         call bend_points_right_ring(IT2)
         call points_moved_right_ring(IT2)
      elseif (length_of_chain(IP) - DIB == 2) then
         call bend_points_left_ring(IT1)
         call points_moved_left_ring(IT1)
         call bend_points_right_ring(IT2)
      elseif (length_of_chain(IP) - DIB == 1) then
         call bend_points_left_ring(IT1)
      else
         print *, 'DIB should not take this value', DIB
         stop 1
      endif
   endif

! Move Explicity Bound points along with they are bound to
   if (WLC_P__EXPLICIT_BINDING) then
      do ii = IT1, IT2
         if (WLC_P__NETWORK) then
            do indx = wlc_network_start_index(ii), &
               wlc_network_start_index(ii + 1) - 1
               otherEnd = wlc_other_beads(indx)
               call slide_another_bead(IT1, IT2, otherEnd, DR)
            enddo
         else
            otherEnd = wlc_ExplicitBindingPair(ii)
            if (otherEnd == -1) cycle ! not a loop
            if (otherEnd >= IT1 .and. otherEnd <= IT2) cycle ! internal loop
            call slide_another_bead(IT1, IT2, otherEnd, DR)
         endif
      enddo
   endif

   I = IT1
   do J = 0, DIB

      if (I == (last_bead_of_chain(IP) + 1) .AND. WLC_P__RING) then
         I = first_bead_of_chain(IP)
      endif

      if (WLC_P__WARNING_LEVEL >= 2) then
         if (.not. isnan(wlc_RP(1, I))) then
            print *, "Should be nan still!!"
            stop
         endif
      endif
      wlc_RP(:, I) = wlc_R(:, I) + DR
      wlc_UP(:, I) = wlc_U(:, I)
      if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
      wlc_nPointsMoved = wlc_nPointsMoved + 1
      wlc_pointsMoved(wlc_nPointsMoved) = I
      I = I + 1
      if (WLC_P__WARNING_LEVEL >= 2) then
         if (duplicates(wlc_pointsMoved(1:wlc_nPointsMoved), wlc_nPointsMoved)) then
            print *, "Duplicates"
            stop
         endif
         if (duplicates(wlc_bendPoints(1:wlc_nBend), wlc_nBend)) then
            print *, "Duplicates bend"
            stop
         endif
      endif

   ENDdo
end subroutine

function duplicates(vec, length) result(output)
   implicit none
   integer length
   integer vec(length)
   integer ii
   logical output
   output = .FALSE.
   if (length < 2) then
      return
   endif
   do ii = 1, length - 1
      if (ANY(vec(ii + 1:length) == vec(ii))) then
         output = .TRUE.
         return
      endif
   enddo
end function

subroutine slide_another_bead(IT1, IT2, otherEnd, DR)
   use polydispersity, only: is_right_end, is_left_end
   use params, only: wlc_RP, wlc_R, wlc_U, wlc_VP, wlc_V, wlc_UP, &
                     wlc_nBend, wlc_bendPoints, wlc_pointsMoved, wlc_nPointsMoved, dp
   implicit none
   integer, intent(in) :: IT1
   integer, intent(in) :: IT2
   integer, intent(in) :: otherEnd
   real(dp), intent(in) :: DR(3)    ! Displacement for slide move
   integer I

   if (otherEnd >= IT1 .and. otherEnd <= IT2) return

! Move Explicitly bound point along with section
   I = otherEnd
   if (isnan(wlc_RP(1, I))) then
      wlc_nPointsMoved = wlc_nPointsMoved + 1
      wlc_pointsMoved(wlc_nPointsMoved) = I
   endif
   wlc_RP(:, I) = wlc_R(:, I) + DR
   wlc_UP(:, I) = wlc_U(:, I)
   if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
! Add ajacent points to RP and bendPoints
   if (otherEnd .ne. IT1 - 1 .and. (.not. is_right_end(otherEnd))) then
      if (.not. ANY(wlc_bendPoints(1:wlc_nBend) == otherEnd)) then
         wlc_nBend = wlc_nBend + 1
         wlc_bendPoints(wlc_nBend) = otherEnd
      endif
      I = otherEnd + 1
      if (isnan(wlc_RP(1, I))) then
         wlc_RP(:, I) = wlc_R(:, I)
         wlc_UP(:, I) = wlc_U(:, I)
         if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
         wlc_nPointsMoved = wlc_nPointsMoved + 1
         wlc_pointsMoved(wlc_nPointsMoved) = I
      endif
   endif
   if (otherEnd .ne. IT2 + 1 .and. (.not. is_left_end(otherEnd))) then
      if (.not. ANY(wlc_bendPoints(1:wlc_nBend) == otherEnd - 1)) then
         wlc_nBend = wlc_nBend + 1
         wlc_bendPoints(wlc_nBend) = otherEnd - 1
      endif
      I = otherEnd - 1
      if (isnan(wlc_RP(1, I))) then
         wlc_RP(:, I) = wlc_R(:, I)
         wlc_UP(:, I) = wlc_U(:, I)
         if (WLC_P__LOCAL_TWIST) wlc_VP(:, I) = wlc_V(:, I)
         wlc_nPointsMoved = wlc_nPointsMoved + 1
         wlc_pointsMoved(wlc_nPointsMoved) = I
      endif
   endif

end subroutine


      subroutine abswpk(beta,cdrs,csts,efac,ibswx,iebal,iindx1,
     $ jcsort,jflag,jssort,kbt,kmax,mosp,narn1,narn2,nbasp,nbaspd,
     $ nbt,nbtmax,ndrs,ndrsmx,ndrsr,nelect,nhydr,no2gaq,nstmax,
     $ nsts,nstsmx,nstsr,qbswx,q6mode,weight)
c
c     This subroutine determines the dominant species and the associated
c     factors required for continued fraction corrections.
c
c     This subroutine is called by:
c
c       EQLIB/absswa.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       beta   = array of normalized Newton-Raphson residual functions
c       q6mode = flag denoting usage for EQ3NR or EQ6:
c                  .false. = EQ3NR
c                  .true.  = EQ6
c
c     Principal output:
c
c       ibswx  = array of species indices of candidates for switching
c                  into the active basis set
c       qbswx  = flag denoting that candidates were found for
c                  basis switching
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax,nbtmax,ndrsmx,nstmax,nstsmx
c
      integer ibswx(nbtmax),iindx1(kmax),jcsort(nstmax),jflag(nstmax),
     $ jssort(nstmax),nbasp(nbtmax),nbaspd(nbtmax),ndrs(ndrsmx),
     $ ndrsr(2,nstmax),nsts(nstsmx),nstsr(2,nstmax)
c
      integer iebal,kbt,narn1,narn2,nbt,nelect,nhydr,no2gaq
c
      logical qbswx,q6mode
c
      real(8) beta(kmax),cdrs(ndrsmx),csts(nstsmx),efac(nbtmax),
     $ mosp(nstmax),weight(nstmax)
c
      real(8) coefdr,coefst
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ix,iy,krow,nb,ns,nse,nsi,nsj
c
      logical qskip
c
      real(8) btest,cx,wsi
c
c-----------------------------------------------------------------------
c
c     Note: the following statements don't really do anything except
c     cause the compiler not to complain that nbt and jssort
c     are not used.
c
      ix = nbt
      iy = ix
      nbt = iy
c
      ix = jssort(1)
      iy = ix
      jssort(1) = iy
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Set flag indicating that candidates for basis switching exist.
c
      qbswx = .false.
c
c     Clear the ibswx array.
c
      call initiz(ibswx,nbtmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Loop over all mass balance relations.
c
      do krow = 1,kbt
        nb = iindx1(krow)
        nse = nbaspd(nb)
        nsj = nbasp(nb)
c
        if (nse.ne.narn1 .and. nse.ne.nhydr .and. nb.ne.iebal .and.
     $    nse.ne.no2gaq .and.nse.ne.nelect) then
c
c         If the current species is not H2O, H+, O2(g,aq), or e-,
c         and is not being used for electrical balancing in EQ3NR,
c         consider a switch.
c
c         Pick a candidate for automatic basis switching if a
c         continued fraction correction would be large. Store
c         the index of the candidate, if any, in the array ibswx.
c
          btest = (beta(krow) + 1.)**efac(nb)
          if (btest .ge. 10.) then
c
            do ns = narn1,narn2
              weight(ns) = coefst(csts,nsts,nstsmx,nstsr,nb,ns,nstmax)
            enddo
c
c           Screen out species in the mass balance that are not
c           linked by current reaction with the current basis species.
c           Do this by setting the corresonding weights to zero.
c
            do ns = narn1,narn2
              if (jflag(ns) .eq. 30) then
c
c               Calling sequence substitutions:
c                 nsj for nse
c
                cx = coefdr(cdrs,ndrs,ndrsmx,ndrsr,nsj,ns,nstmax)
                if (cx .eq. 0.) weight(ns) = 0.
              endif
            enddo
c
            call fbassw(jcsort,jflag,mosp,narn1,narn2,nse,nsi,nsj,
     $      nstmax,weight,wsi)
c
            if (nsi .gt. 0) then
              ibswx(nb) = nsi
              qbswx = .true.
            endif
          endif
        endif
      enddo
c
      end


C$Procedure   STCG01 ( STAR catalog type 1, get star data )

      SUBROUTINE STCG01 ( INDEX,  RA,     DEC,    RASIG,
     .                    DECSIG, CATNUM, SPTYPE, VMAG )

C$ Abstract
C
C     Get data for a single star from a SPICE type 1 star catalog.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     EK
C
C$ Keywords
C
C     None.
C
C$ Declarations

      INTEGER               INDEX
      DOUBLE PRECISION      RA
      DOUBLE PRECISION      DEC
      DOUBLE PRECISION      RASIG
      DOUBLE PRECISION      DECSIG
      INTEGER               CATNUM
      CHARACTER*(*)         SPTYPE
      DOUBLE PRECISION      VMAG

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     INDEX       I   Star index.
C     RA          O   Right ascension in radians.
C     DEC         O   Declination in radians.
C     RAS         O   Right ascension uncertainty in radians.
C     DECS        O   Declination uncertainty in radians.
C     CATNUM      O   Catalog number.
C     SPTYPE      O   Spectral type.
C     VMAG        O   Visual magnitude.
C
C$ Detailed_Input
C
C     INDEX       is the index of the star in the list of stars
C                 that satisfy the selection criteria specified in
C                 the last call to STCF01.
C
C$ Detailed_Output
C
C     RA          is right ascension of the star at the catalog epoch
C                 in radians relative to the J2000 inertial frame.
C
C     DEC         is declination of the star at the catalog epoch in
C                 radians relative to the J2000 inertial frame.
C
C     RASIG       is the uncertainty in right ascension of the star at
C                 the catalog epoch in radians.
C
C     DECSIG      is the uncertainty in declination of the star at
C                 the catalog epoch in radians.
C
C     CATNUM      is the star number in the catalog.
C
C     SPTYPE      is the star's spectral type. See catalog description
C                 for more information regarding encoding of spectral
C                 type values.
C
C     VMAG        is the visual magnitude of the star.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If fetching of any of output values fails, then
C        the error 'SPICE(BADSTARINDEX)' is signalled.
C
C     2) If no star catalog has been loaded, the error is dianosed
C        by a routine called by this one.
C
C     3) If STCF01 was not called first, the EK query
C        error 'SPICE(INVALIDINDEX)' is signalled.
C
C$ Files
C
C     This routine reads the data from SPICE type 1 star catalog file
C     loaded into the program by a call to STCL01.
C
C     SPICE type 1 star catalog files MUST contain a single data table.
C     It can occupy a single segment or it can spread across multiple
C     segments. This table MUST include the following columns:
C
C        column name                data type          units
C     -------------------------------------------------------
C        RA                   DOUBLE PRECISION        DEGREES
C        DEC                  DOUBLE PRECISION        DEGREES
C        RA_SIGMA             DOUBLE PRECISION        DEGREES
C        DEC_SIGMA            DOUBLE PRECISION        DEGREES
C        CATALOG_NUMBER       INTEGER
C        SPECTRAL_TYPE        CHARACTER*(4)
C        VISUAL_MAGNITUDE     DOUBLE PRECISION
C
C     Nulls are not allowed in any of the columns.
C     Other columns can also be present in the table but their data
C     will NOT be accessible through STCF01 and STCG01 --
C     the interface used to access data in the catalog. Note
C     that the names and attributes of these additional columns
C     must be identical for all segments containing this table.
C
C$ Particulars
C
C     This routine is intended to be a part of the user interface to
C     the SPICE type 1 star catalog. It allows the caller to retrieve
C     data for a single star found by STCF01 using the star's
C     index within the search result array. This subroutine MUST
C     NOT be called before a search by STCF01 was done.
C
C     Other routines in the SPICE type 1 star catalog access
C     family are:
C
C        STCL01  load the catalog file and make its data
C                available for search and retrieval.
C
C        STCF01  search through the catalog for all stars within
C                a specified RA-DEC rectangle.
C
C$ Examples
C
C     In the following code fragment, STCG01 is used to retrieve
C     position and characteristics for every star within an RA - DEC
C     rectangle from a particular SPICE type 1 star catalog.
C
C     C
C     C     Load catalog file.
C     C
C           CALL STCL01 ( CATFN, TABNAM, HANDLE )
C     C
C     C     Search through the loaded catalog.
C     C
C           CALL STCF01 ( TABNAM, RAMIN,  RAMAX,
C          .              DECMIN, DECMAX, NSTARS )
C     C
C     C     Retrieve data for every star found.
C     C
C           DO I = 1, NSTARS
C
C              CALL STCG01 ( I, RA, DEC, RASIG, DECSIG,
C          .                 CATNUM, SPTYPE, VMAG )
C
C           END DO
C
C$ Restrictions
C
C     1) The catalog file STCG01 reads data from MUST be loaded
C        by STCL01 and a search through the catalog MUST be done by
C        STCF01 before STCG01 is called.
C
C     2) No other EK queries can be made between the call to STCF01
C        and the call to STCG01.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     B.V. Semenov    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 15-MAY-1996 (BVS)
C
C-&

C$ Index_Entries
C
C     get data for single star from a type 1 star catalog
C
C-&

C$ Revisions
C
C-&

C
C
C     SPICELIB functions
C
      LOGICAL               RETURN
      DOUBLE PRECISION      RPD

C
C     Local variables.
C
      LOGICAL               FOUND
      LOGICAL               NULL

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'STCG01' )
      END IF

C
C     Fetch data from the catalog in the following order
C     as defined QUERY string template in STCF01 routine
C
C           RA, DEC, RASIG, DECSIG, CATNUM, SPTYPE, VMAG
C
C     Check FOUNDs and report error if any of the parameters
C     is not found.
C
C     Since NULLs are not allowed in any of the star catalog
C     columns, no check for NULLs is performed.
C
      CALL EKGD (  1, INDEX, 1, RA, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'RA value for star # not found. '    )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGD (  2, INDEX, 1, DEC, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'DEC value for star # not found. '   )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGD (  3, INDEX, 1, RASIG, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'RASIG value for star # not found. ' )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGD (  4, INDEX, 1, DECSIG, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'DECSIG value for star # not found.' )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGI (  5, INDEX, 1, CATNUM, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'CATNUM value for star # not found.' )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGC (  6, INDEX, 1, SPTYPE, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'SPTYPE value for star # not found.' )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

      CALL EKGD (  7, INDEX, 1, VMAG, NULL, FOUND )
      IF ( .NOT. FOUND ) THEN
         CALL SETMSG ( 'VMAG value for star # not found. '  )
         CALL ERRINT ( '#', INDEX                           )
         CALL SIGERR ( 'SPICE(BADSTARINDEX)'                )
         CALL CHKOUT ( 'STCG01' )
         RETURN
      END IF

C
C     Convert angles to radians before return.
C
      RA     = RA     * RPD()
      DEC    = DEC    * RPD()
      RASIG  = RASIG  * RPD()
      DECSIG = DECSIG * RPD()

      CALL CHKOUT ( 'STCG01' )
      RETURN
      END


      SUBROUTINE W3RTVUNP(IUNIT,IBDATE,PP,TT,QQ,CLAL,CLAM,NLEV,
     $                    IRTCHN,RTRAD,NCHN,STNID,ISATOB,RSATOB,
     $                    DSNAME,IDSDAT,IDSDMP,IERR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    W3RTVUNP    DECODES RTOVS RETRIEVAL DATA FROM BUFR
C   PRGMMR: KEYSER           ORG: NP22        DATE: 1999-01-20
C
C ABSTRACT: READS AND UNPACKS ONE REPORT FROM INPUT RTOVS RETRIEVAL
C   JBUFR FILE INTO SPECIFIED FORMAT. RETURNS INFORMATION IN THE
C   FORMAT DESCRIBED BELOW.  INCLUDES SOUNDING DATA ON 40 LEVELS AND
C   RTOVS RADIANCES FROM 32 CHANNELS (20 HIRS, 4 MSU, 3 SSU, AND 5
C   AVHRR CHANNELS).  ALSO, INFORMATION ABOUT THE INPUT DATA SET
C   ITSELF (NAME, CENTER DATE, DUMP TIME) IS RETURNED.
C
C PROGRAM HISTORY LOG:
C 1997-11-21  BERT B. KATZ/GSC -- ORIGINAL AUTHOR
C 1998-05-05  D.A. KEYSER/NP22 -- STREAMLINED, CORRECTED ERRORS
C 1998-06-15  D.A. KEYSER/NP22 -- MODIFIED TO READ IN LONGITUDE
C     (MNEMONIC "CLON") CORRECTLY WHETHER STORED IN DEG. E, OR IN
C     DEG. W (-) AND DEG. E (+)
C 1998-09-21  D.A. KEYSER/NP22 -- SUBROUTINE NOW Y2K AND FORTRAN 90
C      COMPLIANT
C 1999-01-20 D. A. KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED
C      TO PORT THE CODE TO THE IBM SP
C
C USAGE:    CALL W3RTVUNP(IUNIT,IBDATE,PP,TT,QQ,CLAL,CLAM,NLEV,
C                         IRTCHN,RTRAD,NCHN,STNID,ISATOB,RSATOB,
C                         DSNAME,IDSDAT,IDSDMP,IERR)
C   INPUT ARGUMENT LIST:
C     IUNIT    - UNIT NUMBER OF INPUT FILE CONTAINING RETRIEVAL DATA
C              - IN BUFR FORMAT.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IBDATE   - DATE IN SECTION 1 OF BUFR MESSAGE CONTAINING THIS
C              - RETRIEVAL (IN FORM YYYYMMDDHH)
C     PP       - PRESSURE IN MB AT RETRIEVAL LEVELS (MUST BE
C              - DIMENSIONED TO AT LEAST 40 WORDS BY CALLING PROGRAM
C              - - ONLY 40 WORDS WILL BE FILLED HERE)
C     TT       - VIRTUAL TEMPERATURE IN DEG. K AT RETRIEVAL LEVELS
C              - (MUST BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     QQ       - SPECIFIC HUMIDITY IN G/G AT RETRIEVAL LEVELS (MUST
C              - BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     CLAL     - CLOUD TOP ALBEDO IN PERCENT AT RETRIEVAL LEVELS (MUST
C              - BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     CLAM     - CLOUD AMOUNT AT RETRIEVAL LEVELS (C.T. 0-20-011)
C              - (MUST BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     NLEV     - NUMBER OF RETRIEVAL LEVELS (SHOULD ALWAYS BE 40)
C     IRTCHN   - RTOVS RADIANCE CHANNELS (NUMERIC) (MUST BE
C              - DIMENSIONED TO AT LEAST 32 WORDS BY CALLING PROGRAM -
C              - ONLY 32 WORDS WILL BE FILLED HERE)
C     RTRAD    - RTOVS RADIANCES IN DEG. K (MUST BE DIMENSIONED TO AT
C              - LEAST 32 WORDS BY CALLING PROGRAM - ONLY 32 WORDS
C              - WILL BE FILLED HERE)
C     NCHN     - NUMBER OF RADIANCE CHANNELS (SHOULD ALWAYS BE 32)
C     STNID    - STATION ID (CHAR*8)
C     ISATOB   - 11-WORD INTEGER ARRAY CONTAINING RETURNED DATA
C              - (SEE REMARKS FOR CONTENTS)
C     RSATOB   - 17-WORD REAL ARRAY CONTAINING RETURNED DATA
C              - (SEE REMARKS FOR CONTENTS)
C     DSNAME   - CHARACTER*8 DATA SET NAME (SAME FOR ALL REPORTS IN
C              - A COMMON INPUT DATA SET - SEE REMARKS FOR IERR=1)
C     IDSDAT   - INTEGER DATA SET CENTER DATE IN FORM YYYYMMDDHH (SAME
C              - FOR ALL REPORTS IN A COMMON input data set - see
C              - REMARKS FOR IERR=1)
C     IDSDMP   - INTEGER DATA SET DUMP TIME IN FORM YYYYMMDDHHMM (SAME
C              - FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE
C              - REMARKS FOR IERR=1)
C     IERR     - ERROR RETURN CODE
C                 =  0 OBSERVATION READ AND UNPACKED INTO OUTPUT
C                        ARGUMENT LOCATIONS (SEE ABOVE).  SEE REMARKS
C                        FOR CONTENTS. NEXT CALL TO W3RTVUNP WILL
C                        RETURN NEXT OBSERVATION IN DATA SET.
C                 =  1 INFORMATION ABOUT THE BUFR DATASET IS RETURNED
C                        IN THE OUTPUT ARGUMENTS DSNAME, IDSDAT, IDSDMP
C                        (SEE OUTPUT ARGUMENT LIST ABOVE)
C
C                        THIS SHOULD ALWAYS OCCUR AFTER THE FIRST CALL
C                        TO THIS SUBROUTINE.  NO REPORT IS UNPACKED AT
C                        THIS POINT, AND ONLY DSNAME, IDSDAT, AND
C                        IDSDMP CONTAIN INFORMATION.  ALL SUBSEQUENT
C                        CALLS TO W3RTVUNP SHOULD RETURN THE
C                        OBSERVATIONS IN THIS DATA SET, SEQUENTIALLY,
C                        (IERR=0) UNTIL THE END OF FILE IS ENCOUNTERED
C                        (IERR=2).  THE VALUES STORED IN DSNAME,
C                        IDSDAT, AND IDSDMP WILL CONTINUE TO BE
C                        RETURNED ALONG WITH EACH REPORT WHEN IERR = 0.
C                 =  2 FOR NORMAL END-OF-FILE ENCOUNTERED.
C                 = -1 FOR END-OF-FILE ON FIRST READ -- EMPTY FILE
C                 = -2 FOR INPUT BUFR FILE NOT Y2K COMPLIANT -- NO
C                        PROCESSING DONE
C                 = -3 CENTER DATE COULD NOT BE OBTAINED FROM INPUT
C                        FILE -- NO PROCESSING DONE
C
C   INPUT FILES:
C     UNIT "IUNIT" - FILE CONTAINING BUFR RTOVS DATA
C
C   OUTPUT FILES:
C     UNIT 06 - STANDARD OUTPUT PRINT
C
C REMARKS:
C
C     CONTENTS OF OUTPUT ARGUMENT ISATOB (11 INTEGER WORDS) FOR EACH
C      RETRIEVAL:
C        WORD  1 - NESDIS SATELLITE ID NUMBER (=1 FOR NOAA-11)
C                                             (=2 FOR NOAA-12)
C                                             (=3 FOR NOAA-14)
C        WORD  2 - PREPBUFR REPORT TYPE
C                     (=161 FOR CLEAR PATH OVER LAND)
C                     (=163 FOR CLOUDY PATH OVER LAND)
C                     (=171 FOR CLEAR PATH OVER OCEAN)
C                     (=173 FOR CLOUDY PATH OVER OCEAN)
C                     {NOTE: R. TYPE 162 (NSTAR PATH OVER LAND) AND
C                            R. TYPE 172 (NSTAR PATH OVER OCEAN)
C                            ARE NOT VALID FOR RTOVS}
C        WORD  3 - SWATH LOCATION :  1 INDICATES LEFT  LIMB OF SWATH
C                                   56 INDICATES RIGHT LIMB OF SWATH
C                           USED FOR DETERMINING DISTANCE FROM NADIR
C        WORD  4 - ORBIT NUMBER
C        WORD  5 - NESDIS LAND-SEA FLAG
C        WORD  6 - SATELLITE DATA PROCESSING TECHNIQUE
C                     (=12 FOR CLOUDY PATH)
C                     (=36 FOR CLEAR PATH)
C                     (= 4 FOR UNKNOWN PATH????)
C        WORD  7 - TOVS FILTER FLAG (=0 FOR GOOD)
C                                   (=1 FOR REDUNDANT)
C                   IMPORTANT: REDUNDANT RETRIEVALS ARE AT FULL 80 KM
C                              RESOLUTION; GOOD RETRIEVALS ARE AT
C                              250 KM RESOLUTION
C        WORD  8 - SUPERADIABATIC FLAG (=0 FOR NOT SUPERADIABATIC)
C                                      (.NE. 0 FOR SUPERADIABATIC)
C        WORD  9 - DAY/NIGHT QUALIFIER (=0 FOR NIGHT)
C                                      (=1 FOR DAY)
C        WORD 10 - VERTICAL SIGNIFICANCE (SAT OBSERVATION)
C                                      (BUFR C.T. 0-08-003)
C        WORD 11 - SNOW/ICE FLAGS (TERRAIN TYPE)
C                                      (BUFR C.T. 0-13-039)
C
C     CONTENTS OF OUTPUT ARGUMENT RSATOB (17 REAL WORDS) FOR EACH
C      RETRIEVAL:
C        WORD  1 - OBSERVATION TIME IN HOURS GOOD TO 0.01 HOUR.
C        WORD  2 - LATITUDE IN DEGREES (N+,S-)
C        WORD  3 - LONGITUDE IN DEGREES EAST (0.0 to 359.99)
C        WORD  4 - SURFACE HEIGHT IN METERS
C        WORD  5 - FIRST ABOVE-GROUND TOVS PRESSURE LEVEL IN MB
C        WORD  6 - SKIN TEMPERATURE IN DEGREES K
C        WORD  7 - TOTAL PRECIPITABLE WATER IN MM
C        WORD  8 - TOTAL OZONE IN DOBSONS
C        WORD  9 - SEA SURFACE TEMPERATURE IN DEGREES K
C        WORD 10 - CLOUD-TOP PRESSURE IN MB
C        WORD 11 - SOLAR ZENITH ANGLE IN DEGREES
C        WORD 12 - SATELLITE ELEVATION IN DEGREES
C        WORD 13 - NESDIS AVERAGE NSTAR (CLOUDINESS PARAMETER)
C                   (NOTE: THIS IS NOT OF ANY USE SINCE NSTAR
C                         PATH NOT VALID FOR RTOVS
C                         = -1 FOR CLOUDY PATH
C                         = MISSING FOR CLEAR PATH)
C        WORD 14 - HIRS CHANNEL UTILIZATION FLAGS
C        WORD 15 - MSU CHANNEL UTILIZATION FLAGS
C        WORD 16 - SSU CHANNEL UTILIZATION FLAGS
C        WORD 17 - AVHRR CHANNEL UTILIZATION FLAGS
C
C FOR ALL DATA: MISSING VALUES ARE RETURNED AS 99999.0 (REAL) OR
C               99999 (INTEGER)
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP, CRAY, SGI
C
C$$$

      DATA IFIRST/0/,KOUNTR/0/

      REAL  PP(*),TT(*),QQ(*),CLAL(*),CLAM(*),RTRAD(*)

      INTEGER  IRTCHN(*),JDATE(5),JDUMP(5)

      INTEGER(8) IDSDMP

      CHARACTER*8 SUBSET,DSNAME

      CHARACTER*50 IDTSTR
      DATA IDTSTR/'SAID CLAT CLON TOFF HOUR MINU SECO FOVN ORBN SADF '/
      CHARACTER*5 IDTST2
      DATA IDTST2/'DNQL '/

      CHARACTER*50 INFSTR
      DATA INFSTR/'SOEL ELEV NSAV OZON SDPT HIRC MSUC SSUC AVHC TPWT '/
      CHARACTER*10 INFST1
      DATA INFST1/'CDTP VSAT '/

      CHARACTER*30 SRFSTR
      DATA SRFSTR/'PRES SELV LSQL TMSK SST1 TERR '/

      CHARACTER*25 RETSTR
      DATA RETSTR/'PRLC TMDB MIXR CLAL CLAM '/

      CHARACTER*10 BRTSTR
      DATA BRTSTR/'CHNM TMBR '/

      REAL(8) XIDENT(11),XINFO(12),SRFDAT(6),RETDAT(5,40),BRTDAT(2,32)

      DIMENSION  KOUNT(0:3,4),ISATOB(11),RSATOB(17)
      DATA  KOUNT/16*0/,XMSG/99999./,IMSG/99999/,BMISS/10.E10/

      CHARACTER*8   STNID

      CHARACTER*1   NMCHAR(0:35)
      DATA          NMCHAR/'0','1','2','3','4','5','6','7','8','9',
     $                     'A','B','C','D','E','F','G','H','I','J',
     $                     'K','L','M','N','O','P','Q','R','S','T',
     $                     'U','V','W','X','Y','Z'/

      IF(IFIRST.EQ.0) THEN

C  FIRST TIME IN, SET DATELEN AND GET CENTER AND DUMP TIME FOR FILE
C  ----------------------------------------------------------------

         PRINT *, ' ==> W3RTVUNP -- Y2K/F90 VERSION 01-20-1999'
         IFIRST = 1
         CALL DATELEN(10)
         CALL DUMPBF(IUNIT,JDATE,JDUMP)
cppppp
         print *, 'CENTER DATE (JDATE) = ',jdate
         print *, 'DUMP DATE (JDUMP) = ',jdump
         print *, ' '
cppppp
         IF(JDATE(1).LE.0)  then
            PRINT *, '##W3RTVUNP - CENTER DATE COULD NOT BE ',
     $       'OBTAINED FROM INPUT FILE ON UNIT ',IUNIT,' -- IERR = -3'
            IERR = -3
            RETURN
         END IF
         IF(JDATE(1).LT.100)  THEN

C IF 2-DIGIT YEAR RETURNED IN JDATE(1), MUST USE "WINDOWING" TECHNIQUE
C  TO CREATE A 4-DIGIT YEAR

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

            PRINT *, '##W3RTVUNP - THE FOLLOWING SHOULD NEVER ',
     $       'HAPPEN!!!!!'
            PRINT *, '##W3RTVUNP - 2-DIGIT YEAR IN JDATE(1) RETURNED ',
     $       'FROM DUMPBF (JDATE IS: ',JDATE,') - USE WINDOWING ',
     $       'TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
            IF(JDATE(1).GT.20)  THEN
               JDATE(1) = 1900 + JDATE(1)
            ELSE
               JDATE(1) = 2000 + JDATE(1)
            ENDIF
            PRINT *, '##W3RTVUNP - CORRECTED JDATE(1) WITH 4-DIGIT ',
     $       'YEAR, JDATE NOW IS: ',JDATE
         ENDIF
         IDSDAT = JDATE(1)*1E6+JDATE(2)*1E4+JDATE(3)*1E2+JDATE(4)
         IF(JDUMP(1).LE.0)  THEN
            IDSDMP = 999999999999_8
         ELSE
            IF(JDUMP(1).LT.100)  THEN

C IF 2-DIGIT YEAR RETURNED IN JDUMP(1), MUST USE "WINDOWING" TECHNIQUE
C  TO CREATE A 4-DIGIT YEAR

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

               PRINT *, '##W3RTVUNP - THE FOLLOWING SHOULD NEVER ',
     $          'HAPPEN!!!!!'
               PRINT *, '##W3RTVUNP - 2-DIGIT YEAR IN JDUMP(1) ',
     $          'RETURNED FROM DUMPBF (JDUMP IS: ',JDUMP,') - USE ',
     $          'WINDWOING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
               IF(JDUMP(1).GT.20)  THEN
                  JDUMP(1) = 1900 + JDUMP(1)
               ELSE
                  JDUMP(1) = 2000 + JDUMP(1)
               ENDIF
               PRINT *, '##W3RTVUNP - CORRECTED JDUMP(1) WITH 4-DIGIT ',
     $          'YEAR, JDUMP NOW IS: ',JDUMP
            END IF
            IDSDMP = JDUMP(1)*1E8+JDUMP(2)*1E6+JDUMP(3)*1E4+
     $       JDUMP(4)*1E2+JDUMP(5)
         ENDIF
         DSNAME = 'RTOVS   '
         IERR = 1
         RETURN
      ELSE  IF(IFIRST.EQ.1) THEN

C  SECOND TIME IN, OPEN BUFR DATASET FOR INPUT AND DECODE FIRST MESSAGE
C  --------------------------------------------------------------------

         IFIRST = 2
         CALL OPENBF(IUNIT,'IN',IUNIT)
         CALL READMG(IUNIT,SUBSET,IBDATE,IRET)
         IF(IRET.NE.0) THEN
            WRITE(6,1009) IUNIT
 1009       FORMAT('##W3RTVUNP ERROR: EMPTY FILE IN UNIT ',I5)
            IERR = -1
            RETURN
         ENDIF
         IF(IBDATE.LT.100000000)  THEN
C IF INPUT BUFR FILE DOES NOT RETURN MESSAGES WITH A 4-DIGIT YEAR,
C  SOMETHING IS WRONG (EVEN NON-COMPLIANT BUFR MESSAGES SHOULD
C  CONSTRUCT A 4-DIGIT YEAR AS LONG AS DATELEN(10) HAS BEEN CALLED
            WRITE(6,1209) IUNIT
 1209       FORMAT('##W3RTVUNP ERROR: A 10-DIGIT SECT. 1 BUFR MESSAGE ',
     $       'DATE WAS NOT RETURNED IN UNIT',I5,' - PROBLEM WITH BUFR ',
     $       'FILE')
            IERR = -2
            RETURN
         END IF
      ENDIF

 1000 CONTINUE

C  EACH CALL TO READSB INCREASES "KOUNTR" BY 1 (REGARDLESS OF RESULT)
C  ------------------------------------------------------------------

      KOUNTR = KOUNTR + 1

      CALL READSB(IUNIT,IRET)
      IF(IRET.NE.0) THEN
        CALL READMG(IUNIT,SUBSET,IBDATE,IRET)
        IF(IRET.NE.0) THEN

C  ALL BUFR MESSAGES HAVE BEEN READ AND DECODED -- ALL DONE
C  --------------------------------------------------------

           WRITE(6,1001) IUNIT
 1001 FORMAT(//' ==> W3RTVUNP: END OF FILE ON UNIT',I3,' -- ALL DONE'/)
           IERR = 2
           RETURN
        ENDIF
         IF(IBDATE.LT.100000000)  THEN
C IF INPUT BUFR FILE DOES NOT RETURN MESSAGES WITH A 4-DIGIT YEAR,
C  SOMETHING IS WRONG (EVEN NON-COMPLIANT BUFR MESSAGES SHOULD
c  CONSTRUCT A 4-DIGIT YEAR AS LONG AS DATELEN(10) HAS BEEN CALLED
            WRITE(6,1209) IUNIT
            IERR = -2
            RETURN
         END IF
        GO TO 1000
      ENDIF

      XIDENT = BMISS
      CALL UFBINT(IUNIT,XIDENT,11, 1,IRET,IDTSTR//IDTST2)

      XINFO = BMISS
      CALL UFBINT(IUNIT,XINFO ,12, 1,IRET,INFSTR//INFST1)

      SRFDAT = BMISS
      CALL UFBINT(IUNIT,SRFDAT, 6, 1,IRET,SRFSTR)

      RETDAT = BMISS
      CALL UFBINT(IUNIT,RETDAT, 5,40,NLEV,RETSTR)

      BRTDAT = BMISS
      CALL UFBINT(IUNIT,BRTDAT, 2,32,NCHN,BRTSTR)

      ISATOB = IMSG
      RSATOB = XMSG
      PP(1:40) = XMSG
      TT(1:40) = XMSG
      QQ(1:40) = XMSG
      CLAL(1:40) = XMSG
      CLAM(1:40) = XMSG
      IRTCHN(1:32) = IMSG
      RTRAD(1:32) = XMSG

C  SATELLITE ID
C  ------------

      IF(XIDENT(1).LT.BMISS)  THEN
         ISATOB(1) = NINT(XIDENT(1))
         IF(ISATOB(1).EQ.203) THEN
            ISATOB(1)   = 1
         ELSE IF(ISATOB(1).EQ.204) THEN
            ISATOB(1)   = 2
         ELSE IF(ISATOB(1).EQ.205) THEN
            ISATOB(1)   = 3
         ELSE
            WRITE(6,2071) KOUNTR,NINT(XIDENT(1))
 2071 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS ',
     $ 'AN UNRECOGNIZED SATELLITE ID (=',I5,') - SKIP IT')
            GO TO 1000
         ENDIF
      ELSE
         WRITE(6,2072) KOUNTR
 2072 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING SATELLITE ID - SKIP IT')
         GO TO 1000
      ENDIF

C  LATITUDE
C  --------

      IF(XIDENT(2).LT.BMISS)  THEN
         RSATOB(2) = XIDENT(2)
      ELSE
         WRITE(6,2073) KOUNTR
 2073 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING LATITUDE - SKIP IT')
         GO TO 1000
      ENDIF

C  LONGITUDE
C  ---------

      IF(XIDENT(3).LT.BMISS)  THEN

C Important: According to BUFR Manual, CLON (0-06-002) - represented
C  here by "XIDENT(3)" - should be in units of Degrees West - and East +
C  (-180.0 to +180.0); however some BUFR data sets (e.g., PREPBUFR) are
C  known to encode 0-06-002 in units of Degrees East (0.0 to 359.99) --
C  So we use the following conversion to work in either case ...
         RSATOB(3) = 360._8 - MOD(360._8-XIDENT(3),360._8)
         IF(RSATOB(3).EQ.360.0)  RSATOB(3) = 0.0
      ELSE
         WRITE(6,2074) KOUNTR
 2074 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING LONGITUDE - SKIP IT')
         GO TO 1000
      ENDIF

C  FILTER FLAG
C  -----------

      IF(XIDENT(4).LT.BMISS)  THEN
         ISATOB(7) = NINT(XIDENT(4))
      ELSE
         WRITE(6,2075) KOUNTR
 2075 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING FILTER FLAG - SKIP IT')
         GO TO 1000
       ENDIF

C  OBSERVATION TIME
C  ----------------

      IF(MAX(XIDENT(5),XIDENT(6),XIDENT(7)).LE.BMISS) THEN
         HRFRAC = (60.0 * XIDENT(6) + XIDENT(7)) / 3600.0
         RSATOB(1) = XIDENT(5) + HRFRAC
         RSATOB(1) = 0.01 * AINT(100.0 * RSATOB(1) + 0.5)
      ELSE
         WRITE(6,2076) KOUNTR
 2076 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS ',
     $ 'ONE OR MORE MISSING TIME UNITS - SKIP IT')
         GO TO 1000
      ENDIF

C  SWATH LOCATION
C  --------------

      IF(XIDENT(8).LT.BMISS)  THEN
         ISATOB(3) = NINT(XIDENT(8))
      ELSE
         WRITE(6,2077) KOUNTR
 2077 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING SWATH LOCATION - SKIP IT')
         GO TO 1000
      ENDIF

C  ORBIT NUMBER
C  ------------

      IF(XIDENT(9).LT.BMISS)  ISATOB(4) = NINT(XIDENT(9))

C  SUPERADIABATIC FLAG
C  -------------------

      IF(XIDENT(10).LT.BMISS)  ISATOB(8) = NINT(XIDENT(10))
      IF(ISATOB(8).NE.0)  THEN
         WRITE(6,2078) KOUNTR,ISATOB(8)
 2078 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') IS ',
     $ 'SUPERADIABATIC (FLAG=',I5,') - SKIP IT')
         GO TO 1000
      ENDIF

C  DAY-NIGHT INDICATOR
C  -------------------

      IF(XIDENT(11).LT.BMISS)  ISATOB(9) = NINT(XIDENT(11))

C  SOLAR ZENITH ANGLE
C  ------------------

      IF(XINFO(1).LT.BMISS)  RSATOB(11) = XINFO(1)

C  SOLAR ELEVATION
C  ---------------

      IF(XINFO(2).LT.BMISS)  RSATOB(12) = XINFO(2)

C  AVERAGE NSTAR VALUE
C  -------------------

      IF(XINFO(3).LT.BMISS)  RSATOB(13) = XINFO(3)

C  OZONE
C  -----

      IF(XINFO(4).LT.BMISS)  RSATOB(8) = XINFO(4)

C  SATELLITE DATA PROCESSING TECHNIQUE
C  -----------------------------------

      IF(XINFO(5).LT.BMISS)  THEN
         ISATOB(6) = NINT(XINFO(5))
      ELSE
         WRITE(6,2079) KOUNTR
 2079 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS A',
     $ ' MISSING SATELLITE DATA PROCESSING TECHNIQUE - SKIP IT')
         GO TO 1000
      ENDIF

C  HIRS CHANNEL UTILIZATION FLAGS
C  ------------------------------

      IF(XINFO(6).LT.BMISS)  RSATOB(14) = XINFO(6)

C  MSU CHANNEL UTILIZATION FLAGS
C  ------------------------------

      IF(XINFO(7).LT.BMISS)  RSATOB(15) = XINFO(7)

C  SSU CHANNEL UTILIZATION FLAGS
C  -----------------------------

      IF(XINFO(8).LT.BMISS)  RSATOB(16) = XINFO(8)

C  AVHRR CHANNEL UTILIZATION FLAGS
C  -------------------------------

      IF(XINFO(9).LT.BMISS)  RSATOB(17) = XINFO(9)

C  TOTAL PRECIPITABLE WATER
C  ------------------------

      IF(XINFO(10).LT.BMISS)  RSATOB(7) = XINFO(10) * 10.

C  CLOUD-TOP PRESSURE
C  ------------------

      IF(XINFO(11).LT.BMISS)  RSATOB(10) = XINFO(11) * 0.01

C  VERTICAL SIGNIFICANCE INDICATOR (SATELLITE SOUNDINGS)
C  -----------------------------------------------------

      IF(XINFO(12).LT.BMISS)  ISATOB(10) = NINT(XINFO(12))

C  STATION ID
C  ----------

      STNID = '      R '
      MODSAT = MOD(ISATOB(1),4) + 1
      IF(MODSAT.EQ.4) THEN
         NF = 13
      ELSE IF(MODSAT.EQ.2) THEN
         NF = 17
      ELSE IF(MODSAT.EQ.3) THEN
         NF = 31
      ELSE IF(MODSAT.EQ.1) THEN
         NF = 35
      ENDIF
      INST = IMSG
      IF(ISATOB(6).GE.32) THEN

C  CLEAR PATH
C  ----------

         INST = 1
         STNID(8:8) = NMCHAR(NF-3)
      ELSE IF(ISATOB(6).GE.16) THEN

C  NSTAR PATH ===> NOT VALID FOR RTOVS!!!! - SHOULD NEVER SEE THIS
C  ---------------------------------------------------------------

         INST = 2
         STNID(8:8) = NMCHAR(NF-2)
      ELSE IF(ISATOB(6).GE.8) THEN

C  CLOUDY PATH
C  -----------

         INST = 3
         STNID(8:8) = NMCHAR(NF-1)
      ELSE

C  UNKNOWN PATH
C  ------------

         INST = 0
         STNID(8:8) = NMCHAR(NF)
         WRITE(6,2080) KOUNTR,STNID,ISATOB(6)
 2080 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',A8,
     $ ') HAS AN UNKNOWN SATELLITE DATA PROCESSING TECH. (=',I5,') - ',
     $ 'SKIP IT')
         GO TO 1000
      ENDIF

      KOUNT(INST,MODSAT) = MIN(99999,KOUNT(INST,MODSAT) + 1)
      WRITE(STNID(2:6),'(I5.5)') KOUNT(INST,MODSAT)

      NADIR = INT(ABS(FLOAT(ISATOB(3)) - 28.5)) / 3
      IF(NADIR.LT.9) NADIR = NADIR + 1
      IF(NADIR.GT.0.AND.NADIR.LT.10)  THEN
         STNID(1:1) = NMCHAR(NADIR)
      ELSE
         WRITE(6,2081) KOUNTR,STNID,NADIR
 2081 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',A8,
     $ ') HAS AN INVALID NADIR PROX. IND. (=',I5,') - SKIP IT')
         GO TO 1000
      ENDIF

      IF(NLEV.EQ.40)  THEN

C  FILL IN THE LEVEL SOUNDING DATA - MUST HAVE 40 TEMP LEVELS TO ACCEPT
C  --------------------------------------------------------------------

         DO L = 1,NLEV
            LREV = NLEV + 1 - L
            PP(LREV) = RETDAT(1,L) * 0.01
            IF(RETDAT(2,L).LT.BMISS) THEN
               IF(RETDAT(3,L).GE.BMISS) THEN
                  TT(LREV) = RETDAT(2,L)
               ELSE
                  QQ(LREV) = RETDAT(3,L) / (1.0 + RETDAT(3,L))
                  TT(LREV) = RETDAT(2,L) * (1.0 + 0.61 * QQ(LREV))
               ENDIF
            ELSE
               WRITE(6,3082) KOUNTR
 3082 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,') ',
     $ 'CONTAINS 1 OR MORE MISSING TEMERATURES IN ITS SOUNDING - SKIP ',
     $ 'IT')
               GO TO 1000
            ENDIF
            IF(RETDAT(4,L).LT.BMISS)  CLAL(LREV) = RETDAT(4,L)
            IF(RETDAT(5,L).LT.BMISS)  CLAM(LREV) = RETDAT(5,L)
         ENDDO
      ELSE
         WRITE(6,2082) STNID,KOUNTR,NLEV
 2082 FORMAT(/'##W3RTVUNP WARNING: ID ',A8,' (#',I5,') DOES NOT ',
     $ 'CONTAIN 40 SOUNDING LEVELS (HAS ',I3,' LEVELS) -- NO SOUNDING ',
     $ 'LEVEL DATA PROCESSED')
      ENDIF

      IF(NCHN.EQ.32)  THEN

C  FILL IN THE RADIANCE DATA
C  -------------------------

         DO L = 1,NCHN
            IF(BRTDAT(1,L).LT.BMISS)  IRTCHN(L) = NINT(BRTDAT(1,L))
            IF(BRTDAT(2,L).LT.BMISS)  RTRAD(L)  = BRTDAT(2,L)
         ENDDO
      ELSE
         WRITE(6,2083) STNID,KOUNTR,NCHN
 2083 FORMAT(/'##W3RTVUNP WARNING: ID ',A8,' (#',I5,') DOES NOT ',
     $ 'CONTAIN 32 RADIANCE CHANNELS (HAS ',I3,' CHANNELS) -- NO ',
     $ 'RADIANCE DATA PROCESSED')
      ENDIF

C  BOTTOM LEVEL PRESSURE
C  ---------------------

      IF(SRFDAT(1).LT.BMISS)  THEN
         RSATOB(5) = 0.01 * SRFDAT(1)
      ELSE
         WRITE(6,2084) KOUNTR,STNID
 2084 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',A8,
     $ ') HAS A MISSING BOTTOM PRESSURE LEVEL - SKIP IT')
         GO TO 1000
      ENDIF

C  SURFACE HEIGHT
C  --------------

      IF(SRFDAT(2).LT.BMISS)  THEN
         RSATOB(4) = SRFDAT(2)
      ELSE
         WRITE(6,2085) KOUNTR,STNID
 2085 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',A8,
     $ ') HAS A MISSING SURFACE HEIGHT - SKIP IT')
         GO TO 1000
      ENDIF

C  REPORT TYPE AND LAND/SEA TAG
C  ----------------------------

      IF(SRFDAT(3).LT.BMISS)  THEN
         ISATOB(5) = NINT(SRFDAT(3))
         IF(MOD(ISATOB(5),2).EQ.0)  THEN
            IF(INST.LT.IMSG)  ISATOB(2) = 170 + INST
            ISATOB(5) = 0
         ELSE
            IF(INST.LT.IMSG)  ISATOB(2) = 160 + INST
            ISATOB(5) = 1
         ENDIF
      ELSE
         WRITE(6,2086) KOUNTR,STNID
 2086 FORMAT(/'##W3RTVUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',A8,
     $ ') HAS A MISSING LAND/SEA INDICATOR - SKIP IT')
            GO TO 1000
      ENDIF

C  SKIN TEMPERATURE
C  ----------------

      IF(SRFDAT(4).LT.BMISS)  RSATOB(6) = SRFDAT(4)

C  SEA-SURFACE  TEMPERATURE
C  ------------------------

      IF(SRFDAT(5).LT.BMISS)  RSATOB(9) = SRFDAT(5)

C  TERRAIN INDICATOR
C  -----------------

      IF(SRFDAT(6).LT.BMISS)  ISATOB(11) = NINT(SRFDAT(6))

C  RETURN WITH DECODED RTOVS RETRIEVAL
C  -----------------------------------

      IERR = 0

      RETURN
      END