!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1999-2008, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
module fuliou

  use defs, only   : nv, nv1, mb, pi, totalpower, g, R, ep2
  use cldwtr, only : init_cldwtr, cloud_water
  use solver, only : qft
  use RandomNumbers
  use ckd

  implicit none

  logical, save :: Initialized = .False.
  type(randomNumberSequence), save :: randoms
  real, parameter :: minSolarZenithCosForVis = 1.e-4

contains
  !
  !---------------------------------------------------------------------------
  ! Subroutine rad_init initialize data arrays for gases, ice model and water
  ! model on first call
  !
  subroutine rad_init

    if (.not.Initialized) then
       call init_ckd
       randoms = new_RandomNumberSequence(1)
       call init_cldwtr
       Initialized = .True.
    end if

    Initialized = .True.
  end subroutine rad_init
  ! ----------------------------------------------------------------------
  ! Subroutine rad: Computes radiative fluxes using a band structure
  ! defined by input ckd file
  !

  subroutine rad (as, u0, ss, pts, ee, pp, pt, ph, po, fds, fus, fdir, fuir, &
       plwc, pre, piwc, pde, prwc, pgwc, useMcICA )

    real, intent (in)  :: pp (nv1) ! pressure at interfaces

    real, dimension(nv), intent (in)  :: &
         pt,   & ! temperature [K] at mid points
         ph,   & ! humidity mixing ratio in kg/kg
         po      ! ozone mixing ratio

    real, optional, dimension(nv), intent (in)  :: &
         plwc, & ! cloud liquid water content [g/m^3]
         pre,  & ! effective radius of cloud droplets [microns]
         piwc, & ! cloud ice water content [g/m^3]
         pde,  & ! effective diameter of ice particles [microns]
         prwc, & ! rain water content [g/m^3]
         pgwc    ! graupel water content

    real, intent (in) :: &
         as, & ! broadband albedo (all visible bands given this value)
         ee, & ! broadband surface emissivity (all IR bands given this value)
         u0, & ! cosine of solar zenith angle
         ss, & ! Solar constant
         pts   ! Surface skin temperature

    logical, optional, intent (in ) :: useMcICA

    real, dimension(nv1), intent (out)::  &
         fds, fus,  & ! downward and upward solar flux
         fdir, fuir   ! downward and upward ir flux

    logical            :: McICA = .False.

    if(present(useMcICA)) McICA = useMcICA

    call rad_ir(pts, ee, pp, pt, ph, po, fdir, fuir, &
                 plwc, pre, piwc, pde, prwc, pgwc, McICA  )
    call rad_vis(as, u0, ss, pp, pt, ph, po, fds, fus,  &
                 plwc, pre, piwc, pde, prwc, pgwc, McICA  )

  end subroutine rad

  ! ----------------------------------------------------------------------
  ! Subroutine rad_ir
  ! Computes IR radiative fluxes using a band structure
  ! defined by input ckd file
  !
  subroutine rad_ir (pts, ee, pp, pt, ph, po, fdir, fuir, &
       plwc, pre, piwc, pde, prwc, pgwc, useMcICA  )

    real, intent (in)  :: pp (nv1) ! pressure at interfaces

    real, dimension(nv), intent (in)  :: &
         pt,   & ! temperature [K] at mid points
         ph,   & ! humidity mixing ratio in kg/kg
         po      ! ozone mixing ratio

    real, optional, dimension(nv), intent (in)  :: &
         plwc, & ! cloud liquid water content [g/m^3]
         pre,  & ! effective radius of cloud droplets [microns]
         piwc, & ! cloud ice water content [g/m^3]
         pde,  & ! effective diameter of ice particles [microns]
         prwc, & ! rain water content [g/m^3]
         pgwc    ! graupel water content

    real, intent (in) :: &
         ee, & ! broadband surface emissivity (all IR bands given this value)
         pts   ! Surface skin temperature

    logical, optional, intent (in ) :: useMcICA

    real, dimension(nv1), intent (out)::  &
         fdir, fuir   ! downward and upward ir flux

    ! ----------------------------------------
    logical            :: McICA = .False.
    logical, parameter :: irWeighted = .False.

    real, dimension (nv)   :: tw,ww,tg,dz,tauNoGas, wNoGas, Tau, w
    real, dimension (nv1)  :: fu1, fd1, bf
    real, dimension (nv,4) :: www, pfNoGas, pf

    integer :: ib, ig, k, ig1, ig2, ibandloop, iblimit
    real :: fuq2, xir_norm
    real, dimension(:), allocatable, save :: bandWeights
    real :: randomNumber
    ! ----------------------------------------

    if (.not.Initialized) then
       call init_ckd
       randoms = new_RandomNumberSequence(1)
       call init_cldwtr
       Initialized = .True.
    end if

    if(.not. allocated(bandweights)) then
      allocate(bandweights(size(ir_bands)))
      call computeIRBandWeights(ir_bands, irWeighted, bandWeights)
    end if
    if(present(useMcICA)) McICA = useMcICA

    fdir(:) = 0.0; fuir(:) = 0.0

    call thicks(pp, pt, ph, dz)

    if (McICA) then
       !
       ! Select a single band and g-point (ib, ig1) and use these as the limits
       !   in the loop through the spectrum below.
       !
       randomNumber = getRandomReal(randoms)
       call select_bandg(ir_bands, bandweights, randomNumber, ib, ig1)
       ig2 = ig1
       iblimit = 1
    else
       iblimit = size(ir_bands)
    end if

    bandLoop: do ibandloop = 1, iblimit
      if (.not. McICA) then
         ib  = ibandloop
         ig1 = 1
         ig2 = kg(ir_bands(ib))
      end if
      !
      ! Water vapor continuum optical depth
      !
      call gascon ( center(ir_bands(ib)), pp, pt, ph, TauNoGas )
      wNoGas = 0.; pfNoGas  = 0.
      if (present(plwc)) then
        call cloud_water(ib + size(solar_bands), pre, plwc, dz, tw, ww, www)
        call combineOpticalProperties(TauNoGas, wNoGas, pfNoGas, tw, ww, www)
      end if

      call planck(pt, pts, llimit(ir_bands(ib)), rlimit(ir_bands(ib)), bf)

      gPointLoop: do ig = ig1, ig2
         tau = TauNoGas; w = wNoGas; pf = pfNoGas
         call gases (ir_bands(ib), ig, pp, pt, ph, po, tg )
         call combineOpticalProperties(tau, w, pf, tg)

         !
         ! Solver expects cumulative optical depth
         !
         do k = 2, nv
           tau(k) = tau(k) + tau(k - 1)
         end do
         call qft (.False., ee, 0., 0., bf, tau, w, pf(:, 1), pf(:, 2),      &
              pf(:, 3), pf(:, 4), fu1, fd1)

         if (McICA) then
            xir_norm = 1./bandweights(ib)
         else
            xir_norm = gPointWeight(ir_bands(ib), ig)
         end if

         fdir(:) = fdir(:) + fd1(:) * xir_norm
         fuir(:) = fuir(:) + fu1(:) * xir_norm
      end do gPointLoop
    end do bandLoop
    !
    ! fuq2 is the surface emitted flux in the band 0 - 280 cm**-1 with a
    ! hk of 0.03.
    !
    fuq2 = bf(nv1) * 0.03 * pi * ee
    fuir(:) = fuir(:) + fuq2
  end subroutine rad_ir
  ! ----------------------------------------------------------------------
  ! Subroutine rad_vis: Computes radiative fluxes using a band structure
  ! defined by input ckd file
  !

  subroutine rad_vis (as, u0, ss, pp, pt, ph, po, fds, fus,  &
       plwc, pre, piwc, pde, prwc, pgwc, useMcICA  )

    real, intent (in)  :: pp (nv1) ! pressure at interfaces

    real, dimension(nv), intent (in)  :: &
         pt,   & ! temperature [K] at mid points
         ph,   & ! humidity mixing ratio in kg/kg
         po      ! ozone mixing ratio

    real, optional, dimension(nv), intent (in)  :: &
         plwc, & ! cloud liquid water content [g/m^3]
         pre,  & ! effective radius of cloud droplets [microns]
         piwc, & ! cloud ice water content [g/m^3]
         pde,  & ! effective diameter of ice particles [microns]
         prwc, & ! rain water content [g/m^3]
         pgwc    ! graupel water content

    real, intent (in) :: &
         as, & ! broadband albedo (all visible bands given this value)
         u0, & ! cosine of solar zenith angle
         ss    ! Solar constant

    logical, optional, intent (in ) :: useMcICA

    real, dimension(nv1), intent (out)::  &
         fds, fus    ! downward and upward solar flux

    ! ----------------------------------------
    logical            :: McICA = .False.
    logical, parameter :: solarWeighted = .false.

    real, dimension (nv)   :: tw,ww,tg,tgm,dz, tauNoGas, wNoGas, tau, w
    real, dimension (nv1)  :: fu1, fd1, bf
    real, dimension (nv,4) :: www, pfNoGas, pf

    real, dimension(:), allocatable, save :: bandWeights

    integer :: ib, ig, k, ig1, ig2, ibandloop, iblimit
    real    :: fuq1, xs_norm
    real    :: randomNumber
    ! ----------------------------------------

    if (.not.Initialized) call rad_init

    if (.not. allocated(bandweights)) then
      allocate(bandweights(size(solar_bands)))
      call computeSolarBandWeights(solar_bands, solarWeighted, bandWeights)
    end if
    if(present(useMcICA)) McICA = useMcICA

    fds(:)  = 0.0
    fus(:)  = 0.0
    bf(:)   = 0.0

    if(u0 > minSolarZenithCosForVis) then
      call thicks(pp, pt, ph, dz)

      if (McICA) then
         randomNumber = getRandomReal(randoms)
         !
         ! Select a single band and g-point (ib, ig1) and use these as the
         ! limits in the loop through the spectrum below.
         !
         call select_bandg(solar_bands, bandweights, randomNumber, ib, ig1)
         ig2 = ig1
         iblimit = 1
      else
         iblimit = size(solar_bands)
      end if

      bandLoop: do ibandloop =  1, iblimit
         !
         ! select g points either all, or one depending on McICA
         !
         if (.not. McICA) then
           ib  = ibandloop
           ig1 = 1
           ig2 = kg(solar_bands(ib))
         end if

         !
         ! Rayleigh scattering
         !
         call rayle ( ib, u0, power(solar_bands(ib)), pp, pt, dz, tauNoGas, &
              wNoGas, pfNoGas)
         !
         ! Water vapor continuum
         !
         call gascon ( center(solar_bands(ib)), pp, pt, ph, tgm )
         if(any(tgm > 0.)) &
           call combineOpticalProperties(TauNoGas, wNoGas, pfNoGas, tgm)
         !
         ! Cloud water
         !
         if (present(plwc)) then
           call cloud_water(ib, pre, plwc, dz, tw, ww, www)
           call combineOpticalProperties(TauNoGas, wNoGas, pfNoGas, tw,ww,www)
         end if

         gPointLoop: do ig =  ig1, ig2
           tau = tauNoGas; w = wNoGas; pf = pfNoGas
           call gases (solar_bands(ib), ig, pp, pt, ph, po, tg )
           call combineOpticalProperties(tau, w, pf, tg)

           !
           ! Solver expects cumulative optical depth
           !
           do k = 2, nv
             tau(k) = tau(k) + tau(k - 1)
           end do
           call qft (.true., 0., as, u0, bf, tau, w, pf(:, 1), pf(:, 2),    &
                pf(:, 3), pf(:, 4), fu1, fd1)
           if (McICA) then
              xs_norm =power(solar_bands(ib))/ bandweights(ib)
           else
              xs_norm =gPointWeight(solar_bands(ib), ig)*power(solar_bands(ib))
           end if
           fds(:) = fds(:) + fd1(:) * xs_norm
           fus(:) = fus(:) + fu1(:) * xs_norm
         end do gPointLoop
      end do bandLoop
      !
      ! In this model, we used the solar spectral irradiance determined by
      ! Thekaekara (1973), and 1340.0 W/m**2 is the solar energy contained
      ! in the spectral region 0.2 - 4.0 um., thus scale solar fluxes by
      ! fuq1
      !
      fuq1 = ss / totalpower
      fds(:)  = fds(:)*fuq1
      fus(:)  = fus(:)*fuq1
    end if
  end subroutine rad_vis
  ! ----------------------------------------------------------------------
  ! Subroutine select_bandg
  !
  ! selects the band (i) and the g point (j) based on the probability a
  ! photon would be found in the wavelengths covered by the band and g
  ! point, which is given by g_prob.  Note g_prob sums to unity for both
  ! the solar bands (power > 0.) and the infrared bands respectively.
  !
  subroutine select_bandg(bands, bandweights, randomNumber, i, j)
    type(band_properties), &
          dimension(:),    &
             intent ( in) :: bands
    real, dimension(:), &
             intent ( in) :: bandweights
    real,    intent ( in) :: randomNumber
    integer, intent (out) :: i, j

    real :: cumulative

    i=1; j=1
    ! The probability contained in the first g point of the first band
    cumulative = gPointWeight(bands(i), j) * bandweights(i)

    do while (randomNumber > cumulative .and. cumulative < 1.0)
       j = j+1
       if (j > kg(bands(i)) ) then
          i=i+1
          j=1
       end if
       cumulative = cumulative + gPointWeight(bands(i), j) * bandweights(i)
    end do
  end subroutine select_bandg

  ! ----------------------------------------------------------------------
  ! subroutine thicks: Integrates the hydrostatic equation to provide
  ! layer thicknesses
  !
  subroutine thicks(pp, pt, ph, dz)

    real, intent (in) :: pp(nv1), pt(nv), ph(nv)
    real, intent (out):: dz(nv)

    integer :: i
    real    :: tv

    do  i = 1, nv
       tv = pt(i)*(1+0. + ep2*ph(i) )
       dz(i) = (R/g) * tv * alog( pp(i+1) / pp(i) )
    end do

  end subroutine thicks
  ! ----------------------------------------------------------------------
  !
  subroutine combineOpticalProperties(tau,      ssa,      pF, &
                                      tauToAdd, ssaToAdd, pFtoAdd)
    real, dimension(:),    intent(inout) :: tau, ssa
    real, dimension(:, :), intent(inout) :: pF   ! Phs function (level, moment)
    real, dimension(:),    intent(in)    :: tautoAdd
    real, dimension(:),    optional, intent(in) :: ssaToAdd
    real, dimension(:, :), optional, intent(in) :: pFToAdd ! Phs function

    integer :: j
    !
    ! Adds optical properties to running sum
    !   If ssa and/or w[1-4] are not present we assume the new medium is
    ! strictly absorbring
    !
    if(present(ssaToAdd) .and. present(pfToAdd)) then
       do j = 1, size(pF, 2)
          where (ssa(:) * tau(:) + ssaToAdd(:) * tauToAdd(:) > 0.)
             pf(:, j) = (ssa(:)*tau(:)*pf(:, j) + ssaToAdd(:)*tauToAdd(:)     &
                  * pfToAdd(:, j))/(ssa(:)*tau(:) + ssaToAdd(:) * tauToAdd(:))
          elsewhere
             pf(:, j) = 0.
          end where
       end do
       where (tau(:) + tauToAdd(:) > 0.)
          ssa(:) = (ssa(:) * tau(:) + ssaToAdd(:) * tauToAdd(:)) /            &
               (tau(:) + tauToAdd(:))
       elsewhere
          ssa(:) = 0.
       end where
       tau(:) = tau(:) + tauToAdd(:)
    else
      !
      ! New medium is absorbing - phase function doesn't change
      !
       ssa(:) = (ssa(:) * tau(:)) / (tau(:) + tauToAdd(:))
       tau(:) = tau(:) + tauToAdd(:)
    end if

  end subroutine combineOpticalProperties
  ! ----------------------------------------------------------------------
  ! Subroutine rayle:  computes optical properties associated with rayleigh
  ! scattering
  !
  ! ri is the coefficient in Eq.(4.8) of Fu (1991) to compute the optical
  ! depth due to Rayleigh scattering in the solar bands.
  !
  ! tr, wr, and wwr are the optical depth, single scattering albedo,
  ! and expansion coefficients of the phase function ( 1, 2, 3, and
  ! 4 ) due to the Rayleigh scattering for a given layer.
  !
  subroutine rayle ( ib, u0, power, pp, pt, dz, tr, wr, wwr)
    integer, intent (in) :: ib
    real, intent (in)    :: u0, power, pp(nv1), pt(nv), dz(nv)
    real, intent (out)   :: tr(nv), wr(nv), wwr(nv,4)

    real, parameter :: ri(6)=(/ 0.9022e-5, 0.5282e-6, 0.5722e-7, &
         0.1433e-7, 0.4526e-8, 0.1529e-8 /)

    integer :: i
    real    :: x

    if ( ib == 1 ) then
       x = -3.902860e-6*u0*u0 + 6.120070e-6*u0 + 4.177440e-6
    else
       x = ri(ib)
    endif

    if(power > 0.) then
      do  i = 1, nv
        tr(i) = x * ( pp(i) + pp(i+1) ) * dz(i) * 0.5 / pt(i)
      end do
      wr(:) = 1.0
      wwr(:, :) = 0.
      wwr(:, 2) = 0.5
    else
      tr(:)     = 0.
      wr(:)     = 0.
      wwr(:, :) = 0.
    end if
  end subroutine rayle

  ! *********************************************************************
  ! tgm(nv) are the optical depthes due to water vapor continuum absorp-
  ! tion in nv layers for a given band ib. We include continuum absorp-
  ! tion in the 280 to 1250 cm**-1 region. vv(11)-vv(17) are the central
  ! wavenumbers of each band in this region.
  ! *********************************************************************
  subroutine gascon ( center, pp, pt, ph, tgm)
    real,  intent (in) :: center, pp(nv1), pt(nv), ph(nv)
    real, intent (out) :: tgm(nv)

    integer :: k
    real    :: ff, pe, s, pmid

    if ( center >= 280 .and. center <= 1250.) then
       s = ( 4.18 +  5577.8 * exp ( - 0.00787 * center ) ) / 1013.25
       do k = 1, nv
          pmid   = (pp(k) + pp(k+1))*0.5
          pe     = pmid * ph(k) / ( 0.622 + 0.378 * ph(k) )
          ff     = s*(pe +  0.002*pmid ) *exp (1800.0/pt(k) -6.08108)
          tgm(k) = ff * ph(k) * ( pp(k+1) - pp(k) ) * 1.019767
       end do
    else
       tgm(:) = 0.
    end if
  end subroutine gascon
  ! ----------------------------------------------------------------------
  ! Subroutine planck:  Integrates planck function over band in xk sub
  ! intervals.  The temperatures at the interfaces are taken as the
  ! average of the mid-point temperatures, the temperature at the lowest
  ! pressure interface is set to the temperature at the first mid point,
  ! and surface temperatures are taken as the skin temperature.
  !
  subroutine planck ( pt, tskin, llimit, rlimit, bf)
    real, intent (in)    :: pt(nv), tskin, llimit, rlimit
    real, intent (out)   :: bf(nv1) ! intensity [W/m^2/Sr]

    real, parameter :: xk = 10.

    integer :: k
    real    :: v1, v2, vmid, fq1, fq2, tk

    do k = 1, nv1
       bf(k) = 0.0
    end do

    v1 = llimit
    do while (v1 > rlimit+epsilon(rlimit))
       v2 = max(v1 - xk, rlimit)
       vmid = ( v1 + v2 ) * 0.5
       fq1 = 1.19107e-8 * vmid * vmid * vmid
       fq2 = 1.43884 * vmid
       do k = 2, nv
          tk = (pt(k)+pt(k-1))*0.5
          bf(k) = bf(k) + (fq1/(exp(fq2/tk) - 1.0))*(v1-v2)
       end do
       bf(1) = bf(1) + (fq1/(exp(fq2/pt(1)) - 1.0))*(v1-v2)
       bf(nv1) = bf(nv1) + (fq1/(exp(fq2/tskin) - 1.0))*(v1-v2)
       v1 = v2
    end do

  end subroutine planck
  !
  ! ---------------------------------------------------------------------------
  subroutine computeIRBandWeights(bands, weighted, bandweights)
    type(band_properties), &
          dimension(:), intent( in) :: bands
    logical,            intent( in) :: weighted
    real, dimension(:), intent(out) :: bandweights

    integer :: ib
    !
    ! find the weighting for band points so that the probability of a photon
    ! existing in the g-point range of a band can be calculated, and used for
    ! McICA calculations.  This is the relative band width for the IR bands
    !

    if(size(bands) /= size(bandweights)) &
      stop "Didn't provide the right amount of storage for band weights"
    if(any(isSolar(bands))) stop "Can't compute IR band weights for solar bands."

    if (weighted) then
       do ib = 1, size(bands)
         bandweights(ib) = (llimit(bands(ib)) - rlimit(bands(ib)))/(bllmx-brlmn)
       end do
    else
       bandweights(:) = 1./(real(size(bands)))
    end if
  end subroutine computeIRBandWeights
  ! ---------------------------------------------------------------------------
  subroutine computeSolarBandWeights(bands, weighted, bandweights)
    type(band_properties), &
          dimension(:), intent( in) :: bands
    logical,            intent( in) :: weighted
    real, dimension(:), intent(out) :: bandweights

    integer :: i
    !
    ! find the weighting for band points so that the probability of a photon
    ! existing in the g-point range of a band can be calculated, and used for
    ! McICA calculations.  This is the solar power for the solar bands
    !
        if(size(bands) /= size(bandweights)) &
         stop "Didn't provide the right amount of storage for band weights"
    if(any(.not. isSolar(bands))) stop "Can't compute solar band weights in IR"

    if(weighted) then
       bandweights(:) = (/ (power(bands(i))/totalpower, i = 1, size(bands)) /)
    else
       bandweights(:) = 1./(real(size(bands)))
    end if
  end subroutine computeSolarBandWeights

end module fuliou


C$Procedure ZZPTPL02 ( DSK, map point to plate, type 2 )

      SUBROUTINE ZZPTPL02 ( HANDLE, DLADSC, DSKDSC, POINT,
     .                      PLID,   PLATE,  VERTS,  FOUND )
C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due to the
C     volatile nature of this routine.
C
C     Map a point to the nearest plate in a specified type 2 DSK
C     segment.
C
C     The point is expressed in the reference frame of the segment and
C     represents an offset from the center of the segment's reference
C     frame.
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     DSK
C
C$ Keywords
C
C     GEOMETRY
C     INTERCEPT
C     INTERSECTION
C     RAY
C     SURFACE
C     TOPOGRAPHY
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'dla.inc'
      INCLUDE 'dskdsc.inc'
      INCLUDE 'dsk02.inc'
      INCLUDE 'dsktol.inc'

      INTEGER               HANDLE
      INTEGER               DLADSC ( * )
      DOUBLE PRECISION      DSKDSC ( * )
      DOUBLE PRECISION      POINT  ( 3 )
      INTEGER               PLID
      INTEGER               PLATE  ( 3 )
      DOUBLE PRECISION      VERTS  ( 3, 3 )
      LOGICAL               FOUND

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     HANDLE     I   DSK file handle.
C     DLADSC     I   DLA descriptor of segment.
C     DSKDSC     I   DSK descriptor of segment.
C     POINT      I   Input point.
C     PLID       O   Plate ID.
C     PLATE      O   Plate, expressed as an array of three vertex IDs.
C     VERTS      O   Vertices of plate.
C     FOUND      O   Found flag.
C     PTMEMM     P   Default margin for point-plate distance.
C     XFRACT     P   Default plate expansion fraction.
C
C$ Detailed_Input
C
C     HANDLE     is the handle of a DSK file containing a type 2 DSK
C                segment. The input point is to be matched with the
C                closest plate in this segment.
C
C     DLADSC     is the DLA descriptor of the DSK segment to be used.
C
C     DSKDSC     is the DSK descriptor of the DSK segment to be used.
C
C     POINT      is a point that is on or very near the surface
C                described by the DSK segment. POINT is expressed in
C                the reference frame of the segment and represents an
C                offset from the center of that frame. The frame center
C                may be distinct from the central body of the segment.
C
C$ Detailed_Output
C
C     PLID       is the ID of the plate nearest to the input point, if
C                such a plate is found. A plate ID is the index of a
C                plate in the set of plates contained in the segment.
C                PLID is 1-based.
C
C                The distances between POINT and the respective plates
C                are computed using the plate expansion factor XFRACT.
C                See the Parameters section below and the routine
C                PLTEXP for details.
C
C                A plate will be found only if POINT is sufficiently
C                close to at least one plate in the segment, when plate
C                expansion is taken into account. A margin is used to
C                determine whether a plate is close enough to the point
C                to be considered as a solution. See the Parameters
C                section for details.
C
C
C     PLATE      is the plate designated by PLID. It is an array of
C                three integers. The integers are the IDs of the
C                plate's vertices.
C
C     VERTS      is an array containing the plate's vertices. These
C                a 3-dimensional, double precision vectors. The Ith
C                vertex is stored in elements
C
C                   VERTS(1:3,I)
C
C     FOUND      is a logical flag that is set to .TRUE. if and only
C                if plate nearest to the input point was found
C
C                The outputs PLID, PLATE, and VERTS are valid if and
C                only if FOUND is .TRUE.
C
C$ Parameters
C
C     See the include file
C
C        dsktol.inc
C
C     for declarations of these parameters. These defaults can be
C     overridden. See DSKSTL for details.
C
C
C     PTMEMM     is the default value of the point-plate membership
C                parameter, which is used to determine whether a point
C                is close enough to a plate to be considered as a
C                solution. Let S be the current value of this
C                parameter; the bounding radius of the segment is
C                multiplied by (1+S) to produce a distance used for
C                this comparison.
C
C     XFRACT     is the default value of an expansion factor applied to
C                each plate before the distance of POINT from the plate
C                is computed. Let S be the current value of this
C                parameter; each plate is expanded by a factor of (1+S)
C                to produce a plate used for the membership test.
C
C                This expansion is performed to keep results of this
C                routine consistent with those of DSKX02, which also
C                performs plate expansion.
C
C$ Exceptions
C
C     1)  If an invalid voxel edge length is detected, the error
C         SPICE(VALUEOUTOFRANGE) is signaled.
C
C     2)  If the coarse voxel scale is zero, the error
C         SPICE(VALUEOUTOFRANGE) is signaled.
C
C     3)  If an unrecognized coordinate system is encountered, the
C         error SPICE(NOTSUPPORTED) is signaled.
C
C     4)  If an error occurs while this routine attempts to read
C         DSK data, the error will be signaled by a routine in
C         the call tree of this routine.
C
C$ Files
C
C     Appropriate kernels must be loaded by the calling program before
C     this routine is called.
C
C     The following data are required:
C
C        - DSK data: the DSK file designated by HANDLE and containing
C          the segment having the DLA descriptor DLADSC must be loaded
C          at the time this routine is called.
C
C     Kernel data are normally loaded once per program run, NOT every
C     time this routine is called.
C
C$ Particulars
C
C     This routine supports geometry routines that must associate
C     a computed surface point with the plate to which that point
C     belongs.
C
C$ Examples
C
C     See usage in ZZDSKNRM.
C
C$ Restrictions
C
C     This is a private routine. It is meant to be used only by the DSK
C     subsystem.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 22-FEB-2017 (NJB)
C
C        Added FAILED calls.
C
C        23-AUG-2016 (NJB)
C
C        Bug fix: now saves previous handle and DLA descriptor.
C
C        17-JUN-2016 (NJB)
C
C           Added support for planetodetic coordinates. Updated
C           bounding radius computation for segments using latitudinal
C           coordinates; this routine now calls ZZSEGBOX. Changed
C           implementation to use ZZINVELT and ZZVOXCVO. Updated
C           parameter descriptions.
C
C        07-OCT-2015 (NJB)
C
C           Now uses plate expansion before testing point-plate
C           distance.
C
C        15-DEC-2014 (NJB)
C
C-&

C$ Index_Entries
C
C     map point to plate in type 2 dsk segment
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      VDOT

      INTEGER               BRCKTI
      INTEGER               ZZVOX2ID

      LOGICAL               DLASSG
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ = 1000 )

C
C     Local variables
C
      DOUBLE PRECISION      BOXCTR ( 3 )
      DOUBLE PRECISION      DIST
      DOUBLE PRECISION      DMIN
      DOUBLE PRECISION      LIMIT
      DOUBLE PRECISION      OFFSET ( 3 )
      DOUBLE PRECISION      MAXR
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      PNEAR  ( 3 )
      DOUBLE PRECISION      PNTOFF ( 3 )
      DOUBLE PRECISION      PTSRFM
      DOUBLE PRECISION      VOXORI ( 3 )
      DOUBLE PRECISION      VOXSIZ
      DOUBLE PRECISION      VRTTMP ( 3, 3 )
      DOUBLE PRECISION      XPDFRC
      DOUBLE PRECISION      XVERTS ( 3, 3 )

      INTEGER               CGRCOR ( 3 )
      INTEGER               CGREXT ( 3 )
      INTEGER               CGROFF ( 3 )
      INTEGER               CGRPTR
      INTEGER               CGRSCL
      INTEGER               CORSYS
      INTEGER               CGRVID
      INTEGER               I
      INTEGER               J
      INTEGER               K
      INTEGER               N
      INTEGER               NPLATE
      INTEGER               NREAD
      INTEGER               PIDTMP
      INTEGER               PLTBUF ( BUFSIZ )
      INTEGER               PLTPTR
      INTEGER               PLTTMP ( 3 )
      INTEGER               PTRLOC
      INTEGER               PRVDSC ( DLADSZ )
      INTEGER               PRVHAN
      INTEGER               PTROFF
      INTEGER               REMAIN
      INTEGER               START
      INTEGER               VGRCOR ( 3 )
      INTEGER               VGREXT ( 3 )
      INTEGER               VID

      LOGICAL               INSIDE
      LOGICAL               PASS1

C
C     Saved variables
C
      SAVE                  CGRSCL
      SAVE                  CORSYS
      SAVE                  LIMIT
      SAVE                  MAXR
      SAVE                  PASS1
      SAVE                  PRVHAN
      SAVE                  PRVDSC
      SAVE                  VGREXT
      SAVE                  VOXORI
      SAVE                  VOXSIZ

C
C     Initial values
C
      DATA                  LIMIT  / -1.D0      /
      DATA                  PASS1  / .TRUE.     /
      DATA                  PRVDSC / DLADSZ * 0 /
      DATA                  PRVHAN / 0          /

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZPTPL02' )

C
C     No plate has been found so far.
C
      FOUND = .FALSE.

C
C     Decide whether we're looking at the segment we saw
C     on the previous call.
C
      IF (  PASS1  .OR.
     .      .NOT.  DLASSG( HANDLE, PRVHAN, DLADSC, PRVDSC )  ) THEN
C
C        We'll need to look up the voxel grid parameters for this
C        segment.
C
         CALL DSKD02 ( HANDLE, DLADSC, KWVXOR, 1, 3, N, VOXORI )
         CALL DSKD02 ( HANDLE, DLADSC, KWVXSZ, 1, 1, N, VOXSIZ )
         CALL DSKI02 ( HANDLE, DLADSC, KWVGRX, 1, 3, N, VGREXT )
         CALL DSKI02 ( HANDLE, DLADSC, KWCGSC, 1, 1, N, CGRSCL )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'ZZPTPL02' )
            RETURN
         END IF

         IF ( VOXSIZ .EQ. 0.D0 ) THEN

            CALL SETMSG ( 'Voxel edge length is zero; length '
     .      //            'must be positive.'                  )
            CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'             )
            CALL CHKOUT ( 'ZZPTPL02'                           )
            RETURN

         END IF

         IF ( CGRSCL .EQ. 0 ) THEN

            CALL SETMSG ( 'Coarse voxel scale is zero; scale '
     .      //            'must be positive.'                  )
            CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'             )
            CALL CHKOUT ( 'ZZPTPL02'                           )
            RETURN

         END IF

         CORSYS = NINT( DSKDSC(SYSIDX) )

         CALL ZZSEGBOX ( DSKDSC, BOXCTR, MAXR )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'ZZPTPL02' )
            RETURN
         END IF

C
C        We succesfully obtained the desired segment parameters, so we
C        don't need to execute this code again until the segment
C        changes. Save the current handle and DLA descriptor.
C
         PRVHAN = HANDLE
         CALL MOVEI ( DLADSC, DLADSZ, PRVDSC )

         PASS1  = .FALSE.

      END IF

C
C     Look up the point-plate membership margin; compute
C     the distance limit. This call must be made on every
C     call to ZZPTPL02.
C
      CALL DSKGTL ( KEYPTM, PTSRFM )

      LIMIT = PTSRFM * MAXR

C
C     Look up the plate expansion fraction. This call must be made on
C     every call to ZZPTPL02.
C
      CALL DSKGTL ( KEYXFR, XPDFRC )

C
C     Find out whether the point is within the volume element
C     bounding the segment.
C
      CALL ZZINVELT ( POINT,          CORSYS, DSKDSC(PARIDX),
     .                DSKDSC(MN1IDX), PTSRFM, 0,              INSIDE )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN
      END IF

      IF ( .NOT. INSIDE ) THEN
C
C        The point is too far from the segment to be considered
C        to lie on a plate in that segment.
C
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN

      END IF

C
C     Map the point to the coordinates of a voxel containing it. If the
C     point is outside the voxel grid, map the point to the closest
C     voxel.
C
      CALL VSUB ( POINT, VOXORI, OFFSET )

      DO I = 1, 3

         J         = INT( OFFSET(I) / VOXSIZ ) + 1

         VGRCOR(I) = BRCKTI( J,  1,  VGREXT(I) )

      END DO

C
C     Compute the coordinates of the coarse voxel containing the fine
C     voxel we just identified. Get the 1-d offset of the fine voxel
C     relative the coarse voxel; this offset gives us the index of the
C     pointer associating the fine voxel with its plate list. The
C     1-d offset PTROFF is 1-based.
C
      CALL ZZVOXCVO ( VGRCOR, VGREXT, CGRSCL, CGRCOR, CGROFF, PTROFF )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN
      END IF

C
C     Fetch the pointer from the coarse voxel to the first element of
C     its fine voxel pointer array.
C
C     We'll need the 1-D offset of the coarse voxel from the base of
C     the coarse voxel grid.
C
      DO I = 1, 3
         CGREXT(I) = VGREXT(I) / CGRSCL
      END DO

      CGRVID = ZZVOX2ID ( CGRCOR, CGREXT )

      CALL DSKI02 ( HANDLE, DLADSC, KWCGPT, CGRVID, 1, N, CGRPTR )

      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN
      END IF

      IF ( CGRPTR .LT. 1 ) THEN
C
C        There are no non-empty fine voxels, hence no plates, in the
C        coarse voxel we're looking at.
C
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN

      END IF
C
C     Look up the pointer to the plate list for this voxel, and if
C     the pointer is non-null, look up the plate count.
C
      PTRLOC = (CGRPTR - 1) + PTROFF

      CALL DSKI02 ( HANDLE, DLADSC, KWVXPT, PTRLOC, 1, N, PLTPTR )

      IF (  FAILED()  .OR.  ( PLTPTR .LT. 1 )  ) THEN
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN
      END IF

      CALL DSKI02 ( HANDLE, DLADSC, KWVXPL, PLTPTR, 1, N, NPLATE )

      IF (  FAILED()  .OR.  ( NPLATE .LT. 1 )  ) THEN
         CALL CHKOUT ( 'ZZPTPL02' )
         RETURN
      END IF

C
C     Loop through the plates, keeping track of the minimum plate-point
C     distance.
C
      DMIN   = DPMAX()
      REMAIN = NPLATE
      NREAD  = MIN ( REMAIN, BUFSIZ )
      I      = 1

      DO WHILE ( REMAIN .GT. 0 )
C
C        Look up the current set of plate IDs.
C
         CALL DSKI02 ( HANDLE,   DLADSC, KWVXPL,
     .                 PLTPTR+I, NREAD,  N,      PLTBUF )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'ZZPTPL02' )
            RETURN
         END IF
C
C        Look up the vertices of each plate in the buffer and find
C        the distance of the point from that plate. Quit if we
C        find a match.
C
         DO J = 1, NREAD

            PIDTMP = PLTBUF(J)
            START  = ( 3*(PIDTMP-1) ) + 1

            CALL DSKI02 ( HANDLE, DLADSC, KWPLAT, START, 3, N, PLTTMP )

            DO K = 1, 3

               VID   = PLTTMP(K)
               START = ( 3*(VID-1) ) + 1

               CALL DSKD02 ( HANDLE, DLADSC, KWVERT,
     .                       START,  3,      N,      VRTTMP(1,K) )

            END DO

            IF ( FAILED() ) THEN
               CALL CHKOUT ( 'ZZPTPL02' )
               RETURN
            END IF

C
C           Work with an expanded version of the plate.
C
            CALL PLTEXP ( VRTTMP, XPDFRC, XVERTS )

            CALL PLTNRM ( XVERTS(1,1), XVERTS(1,2), XVERTS(1,3),
     .                    NORMAL                                )

            IF ( FAILED() ) THEN
               CALL CHKOUT ( 'ZZPTPL02' )
               RETURN
            END IF

            CALL VHATIP ( NORMAL )

            CALL VSUB ( POINT, XVERTS(1,1), PNTOFF )

            IF ( ABS( VDOT(PNTOFF,NORMAL) ) .LE. LIMIT ) THEN
C
C              The input point lies in a narrow region of space
C              bounded by two planes, both of which are parallel
C              to the plate. The plate lies between the planes.
C
C              This test does not rule out a comparison between POINT
C              and a distant plate, if POINT is close to the plane
C              containing that plate. However, the proportion of such
C              cases will normally be small.
C
               CALL PLTNP ( POINT,       XVERTS(1,1), XVERTS(1,2),
     .                      XVERTS(1,3), PNEAR,       DIST        )

               IF ( FAILED() ) THEN
                  CALL CHKOUT ( 'ZZPTPL02' )
                  RETURN
               END IF

            ELSE
               DIST = DPMAX()
            END IF

            IF ( DIST .LE. LIMIT ) THEN
C
C              We have a reasonable candidate for the closest plate.
C
               FOUND = .TRUE.

               IF ( DIST .LT. DMIN ) THEN

                  DMIN  = DIST
                  PLID  = PIDTMP
C
C                 Set the output vertices to the original version.
C
                  CALL MOVEI ( PLTTMP, 3, PLATE )
                  CALL MOVED ( VRTTMP, 9, VERTS )
C
C                 We'll return the above values if we don't find
C                 a better match.
C
               END IF

            END IF

         END DO

C
C        Prepare to read the next set of plate IDs, if any.
C
         REMAIN = REMAIN - NREAD
         I      = I      + NREAD
         NREAD  = MIN ( REMAIN, BUFSIZ )

      END DO

      CALL CHKOUT ( 'ZZPTPL02' )
      RETURN
      END


C$Procedure      SPKE12 ( S/P Kernel, evaluate, type 12 )

      SUBROUTINE SPKE12 ( ET, RECORD, STATE )

C$ Abstract
C
C     Evaluate a single data record from a type 12 SPK segment.
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     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      IMPLICIT NONE

      INTEGER               MAXREC
      PARAMETER           ( MAXREC = 129 )

      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )
      DOUBLE PRECISION      STATE    ( 6 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     MAXREC     P   Maximum size of SPK record.  See SPKPVN.
C     ET         I   Epoch for which a state is desired.
C     RECORD     I   Record from a type 12 SPK segment valid for ET.
C     STATE      O   State (position and velocity) at epoch ET.
C
C$ Detailed_Input
C
C     ET             is the epoch for which a state vector is desired.
C
C     RECORD         is a record from a type 12 SPK segment which, when
C                    evaluated at epoch ET, will give the state
C                    (position and velocity) of some body, relative to
C                    some center, in some inertial reference frame.
C
C                    The structure of the record is as follows:
C
C                       +----------------------+
C                       | number of states (n) |
C                       +----------------------+
C                       | start epoch          |
C                       +----------------------+
C                       | step size            |
C                       +----------------------+
C                       | state 1 (6 elts.)    |
C                       +----------------------+
C                       | state 2 (6 elts.)    |
C                       +----------------------+
C                                   .
C                                   .
C                                   .
C                       +----------------------+
C                       | state n (6 elts.)    |
C                       +----------------------+
C
C
C$ Detailed_Output
C
C     STATE    is the state vector at epoch ET. Its contents are, in
C              order, X, Y, Z, X', Y', and Z'. Units are km and km/sec.
C
C$ Parameters
C
C     MAXREC   is the maximum size of SPK record.  See the SPICELIB
C              routine SPKPVN for details.
C
C$ Exceptions
C
C     None.  This routine assumes that the input record is valid.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The exact format and structure of type 12 (unequally spaced
C     discrete states, evaluated by Hermite interpolation) SPK segments
C     is described in the SPK Required Reading.
C
C$ Examples
C
C     The SPKEnn routines are almost always used in conjunction with
C     the corresponding SPKRnn routines, which read the records from
C     SPK files.
C
C     The data returned by the SPKRnn routine is in a raw form, taken
C     directly from the segment.  As such, it will be not be directly
C     useful to a user unless they have a complete understanding of the
C     structure of the data type.  Given that understanding, however,
C     the SPKRnn routines could be used to "dump" and check segment data
C     for a particular epoch before evaluating the record to obtain a
C     state vector, as in the example which follows.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     C
C     C     Look at parts of the descriptor.
C     C
C           CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C
C           CENTER = ICD( 2 )
C           REF    = ICD( 3 )
C           TYPE   = ICD( 4 )
C
C           IF ( TYPE .EQ. 12 ) THEN
C
C              CALL SPKR12 ( HANDLE, DESCR, ET, RECORD )
C                  .
C                  .  Look at the RECORD data.
C                  .
C              CALL SPKE12 ( ET, RECORD, STATE )
C                  .
C                  .  Check out the evaluated state.
C                  .
C           END IF
C
C$ Restrictions
C
C     1)  This routine assumes that the input record is valid.  Any
C         checking of the input data is assumed to have been performed
C         when the source SPK file was created.
C
C$ Literature_References
C
C     NAIF Document 168.0, "S- and P- Kernel (SPK) Specification and
C     User's Guide"
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 06-NOV-1999 (NJB)
C
C-&

C$ Index_Entries
C
C     evaluate type_12 spk segment
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               SIZIDX
      PARAMETER           ( SIZIDX = 1 )

      INTEGER               STRIDX
      PARAMETER           ( STRIDX = SIZIDX + 1 )

      INTEGER               STPIDX
      PARAMETER           ( STPIDX = STRIDX + 1 )

      INTEGER               STAIDX
      PARAMETER           ( STAIDX = STPIDX + 1 )

C
C     Local variables
C
      DOUBLE PRECISION      LOCREC ( MAXREC )
      DOUBLE PRECISION      WORK   ( MAXREC * 2,  2 )

      INTEGER               FROM
      INTEGER               I
      INTEGER               J
      INTEGER               N
      INTEGER               TO
      INTEGER               XSTART

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'SPKE12' )

      N =  NINT( RECORD(SIZIDX) )

C
C     We interpolate each state component in turn.
C
      XSTART   =   2  +  6 * N

      DO I = 1, 3

         DO J = 1, N
C
C           For the Jth input state vector, copy the Ith position and
C           velocity components into the local record buffer LOCREC.
C
            FROM         = STAIDX - 1 + 6*(J-1) + I
            TO           = 2*J    - 1

            LOCREC(TO  ) = RECORD ( FROM     )
            LOCREC(TO+1) = RECORD ( FROM + 3 )

         END DO

C
C        Interpolate the Ith position and velocity components of the
C        state.
C
         CALL HRMESP ( N,
     .                 RECORD(STRIDX),
     .                 RECORD(STPIDX),
     .                 LOCREC,
     .                 ET,
     .                 WORK,
     .                 STATE(I  ),
     .                 STATE(I+3)      )

      END DO

      CALL CHKOUT ( 'SPKE12' )
      RETURN
      END


      BLOCK DATA bd_gem_grid
C*************************************************************************
C
C  Information array for GEMPAK GRIB decoder Gribtogem version 2
C
C	INFO ARRAY ORDER:
C
C	1-6	= A-F grids (NMC id 21-26)
C	7	= G grid (NMC id 50)
C	8	= NMC id 5
C	9	= NMC id 6
C	10	= NMC id 27 (NH)
C	11	= NMC id 28 (SH)
C	12	= NMC id 100
C	13	= NMC id 101
C	14	= NMC id 104
C	15	= NMC id 105
C	16-19	= ECMWF id 1-4 (NH)
C	20-23	= ECMWF id 9-12 (SH)
C	24-27	= ECMWF id 5-8 (35N-35S)
C	28	= ETA 80km Resolution id 211
C	29	= Grid 256-usually thickened NMC AVN thinned grids
C	30-33	= NMC id 61-64
C       34      = NMC id 87 US Maps/Ruc
C       35      = NMC id 212 40km ETA
C       36      = NMC id 207 Alaska grid
C       37      = NMC id 214 Alaska grid
C       38      = NMC id 2 Global 2.5
C       39      = NMC id 203 Alask AVN
C       40      = NMC id 215 20km ETA
C       41      = NMC id 94 ETA 29km
C       42      = NMC id 96 ETA 48km
C       43      = NMC id 99 ETA 15km
C       44      = NMC id 192 ETA 10km West
C       45      = NMC id 196 ETA 10km East
C       46      = NMC id 3
C       47      = NMC 201
C       48	= NMC 202
C       49      = NMC 204
C       50	= NMC 205
C       51      = NMC 236 RUC2
C       52      = NMC 213 National CONUS double res
C       53	= NMC 103 N. Hemisphere polar stereographic 105W
C       54      = NMC 255, Use gds
C
C Log
C Unknown
C P.Bruehl/Undiata	5/95	Gribtogem v.2.
C Chiz/Unidata		10/96	New grids
C***************************************************************
	INCLUDE 'gem_grid.inc'

C
C     nmc is the index into the info arrays for NMC grids
C
	DATA nmc/0, 38, 46, 0, 8, 9, 14*0, 1, 2, 3, 4, 5, 6, 10, 11,
     &         21*0, 7, 10*0, 30, 31, 32, 33, 22*0, 34, 6*0, 41, 0,
     &         42, 2*0, 43, 12, 13, 0, 53, 14, 15, 86*0, 44, 3*0, 45,
     &         4*0, 47, 48, 39, 49, 50, 0, 36, 3*0, 28, 35, 52, 37, 40,
     &         20*0, 51, 18*0, 54, 29/
C
C     ecmwf is the index into the info arrays for ECMWF grids
C
	DATA ecmwf/16, 17, 18, 19, 24, 25, 26, 27, 20, 21, 22, 23,
     &             242*0,54,0/
C
	DATA ukm/0,38,46,251*0,54,0/
C
C     subgrid is a flag to indicate part of a larger grid
C
	DATA subgrid/6*.TRUE., 9*.FALSE., 12*.TRUE.,.FALSE.,.TRUE.,
     &	 	     4*.TRUE.,21*.FALSE./
C
C     tgrid_id is the grid id to check for compatibility
C
	DATA tgrid_id/4*1, 2*5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 8*16,
     &     4*20, 28, 29, 4*30, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43,
     &     44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54/
C
C     scol is the starting column for subgrids
C
	DATA scol/1, 37, 1, 37, 1, 1, 9*0, 109, 73, 37, 1,
     &     109, 73, 37, 1, 109, 73, 37, 1, 0, 9999, 1, 91, 1, 91, 21*0 /
C
C     srow is the starting row for subgrids
C
	DATA srow/37, 37, 1, 1, 19, 1, 9*0, 4*37, 8*1, 0, 9999,
     &       46, 46, 1, 1, 21*0/
C
C     polepos is the position of the pole point (if applicable)
C	No longer needed, pole expansion done by {gribto}
C
C	DATA polepos/2*1333, 2*1, 1297, 1, 21*0, 0/
C
C     ngx is the number of longitude points in a large grid
C
	DATA ngx/4*73, 2*72, 9*0, 12*145, 0, 9999, 4*181, 21*0/
C
C     ngy is the number of latitude points in a large grid
C
	DATA ngy/4*73, 2*37, 9*0, 8*73, 4*29, 0, 9999, 4*91, 21*0/
C
C     rlatb is the bottom latitude of the grid
C
	DATA rlatb/6*-90.0, 20.0, 2*7.634903, -20.84062,
     &     20.84062, 17.09924, 10.51680, -0.268327, 17.5288,
     &     8*-90.0, 4*-35.0, 12.190, -90., 4*-90., 22.8756,
     &     12.190, 2*42.085, -90., 19.132, 12.190, 9.678, -3.441,
     &     17.912, 29.366, 23.476, -90., -20.826, 7.838, -25.000,
     &     0.616, 16.28, 7.838, 22.405, -9999./
C
C     rlatt is the top latitude of the grid
C
	DATA rlatt/6*90.0, 60.0, 42.8876, 44.27935, -20.84062,
     &     20.84062, 53.504, 44.48691, 32.7473, 53.7708,
     &     8*90.0, 4*35.0, 57.290, 90.,4*90., 46.0172, 57.290,
     &     2*63.976, 90., 57.634, 57.290, 53.708, 50.026, 45.508,
     &     49.150, 43.337, 90.,-20.826,35.617,60.644,45.620,55.48,
     &     35.617, 48.920, -9999. /

C
C     rlonl is the left longitude of the grid
C
	DATA rlonl/6*0.0, -140.0, 2*-133.4429, -125.0, 125.0,
     &  -129.2958, -137.1459, -139.475, -129.296, 12*0.0, -133.459,
     &  -30.,4*0., -120.4911, -133.459, 2*-175.641, 0., 174.163,
     &  -133.459, -128.826, -148.799, -98.303, -126.316, -96.745,
     &  0.,-150.000,-141.028,110.0,-84.904,-126.14,-141.028,-121.352,
     &  -9999. /
C
C     rlonr is the right longitude of the grid
C
	DATA rlonr/4*0.0,2*355.00,-52.5,2.102730,-23.74616,55.0,-55.0,
     &  -22.37376,-16.57655,-14.5993,-22.3738,12*0.0,-49.385,-30.,4*0.,
     &  -60.8284, -49.385, 2*-93.689, -2.5, -53.66, -49.385, -35.567,
     &  -3.230, -62.002, -99.844, -72.401, -1.0,30.000,-18.576,-109.129,
     &  -15.000,-57.38,-18.577,-50.811, -9999. /
C
C     ang1, ang2, ang3 are the angles for the polar stereographic grids
C
	DATA ang1/7*0, 3*90.0, -90.0, 4*90.0, 12*0, 25.,5*0, 90.0, 25.,
     &            2*90.0, 0, 90., 25., 41., 50., 33., 40., 34., 0,
     &            2*90.0, 0, 90.,25.,90.,90., -9999. /
	DATA ang2/7*0, 2*-105.0, -80.0, 100.0, 4*-105.0, 12*0, -95.,5*0,
     &       -105.0, -95., 2*-150.0,0,-150.,-95.,-97., -111., -83.,
     &       -115., -86., 0, 2*-105., 0., -60.,-95.,2*-105., -9999. /
	DATA ang3/27*0, 25., 5*0, 0, 25., 4*0, 25., 10*0,25.,2*0,-9999. /
C
C     proj is the projection type
C
	DATA proj/7*'CED',3*'STR','SPS',4*'STR',12*'CED','LCC',5*'CED',
     &            'STR', 'LCC', 2*'STR', 'CED', 'STR', 'LCC', 6*'CED',
     &            2*'STR','MER','STR','LCC',2*'STR','xxx' /

      END


MODULE closea
   !!======================================================================
   !!                       ***  MODULE  closea  ***
   !! Closed Seas  : specific treatments associated with closed seas
   !!======================================================================
   !! History :   8.2  !  00-05  (O. Marti)  Original code
   !!             8.5  !  02-06  (E. Durand, G. Madec)  F90
   !!             9.0  !  06-07  (G. Madec)  add clo_rnf, clo_ups, clo_bat
   !!        NEMO 3.4  !  03-12  (P.G. Fogli) sbc_clo bug fix & mpp reproducibility
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   dom_clo    : modification of the ocean domain for closed seas cases
   !!   sbc_clo    : Special handling of closed seas
   !!   clo_rnf    : set close sea outflows as river mouths (see sbcrnf)
   !!   clo_ups    : set mixed centered/upstream scheme in closed sea (see traadv_cen2)
   !!   clo_bat    : set to zero a field over closed sea (see domzrg)
   !!----------------------------------------------------------------------
   USE oce             ! dynamics and tracers
   USE dom_oce         ! ocean space and time domain
   USE phycst          ! physical constants
   USE in_out_manager  ! I/O manager
   USE lib_fortran,    ONLY: glob_sum, DDPDD
   USE lbclnk          ! lateral boundary condition - MPP exchanges
   USE lib_mpp         ! MPP library
   USE timing

   IMPLICIT NONE
   PRIVATE

   PUBLIC dom_clo      ! routine called by domain module
   PUBLIC clo_bat      ! routine called in domzgr module

   INTEGER, PUBLIC, PARAMETER          ::   jpncs   = 4      !: number of closed sea
   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncstt            !: Type of closed sea
   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncsi1, ncsj1     !: south-west closed sea limits (i,j)
   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncsi2, ncsj2     !: north-east closed sea limits (i,j)
   INTEGER, PUBLIC, DIMENSION(jpncs)   ::   ncsnr            !: number of point where run-off pours
   INTEGER, PUBLIC, DIMENSION(jpncs,4) ::   ncsir, ncsjr     !: Location of runoff

   REAL(wp), DIMENSION (jpncs+1)       ::   surf             ! closed sea surface

   !! * Substitutions
   !!----------------------------------------------------------------------
   !!                   ***  vectopt_loop_substitute  ***
   !!----------------------------------------------------------------------
   !! ** purpose :   substitute the inner loop start/end indices with CPP macro
   !!                allow unrolling of do-loop (useful with vector processors)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OPA 3.7 , NEMO Consortium (2014)
   !! $Id: vectopt_loop_substitute.h90 4990 2014-12-15 16:42:49Z timgraham $
   !! Software governed by the CeCILL licence (./LICENSE)
   !!----------------------------------------------------------------------
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: closea.F90 5836 2015-10-26 14:49:40Z cetlod $
   !! Software governed by the CeCILL licence     (./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   SUBROUTINE dom_clo
      !!---------------------------------------------------------------------
      !!                  ***  ROUTINE dom_clo  ***
      !!
      !! ** Purpose :   Closed sea domain initialization
      !!
      !! ** Method  :   if a closed sea is located only in a model grid point
      !!                just the thermodynamic processes are applied.
      !!
      !! ** Action  :   ncsi1(), ncsj1() : south-west closed sea limits (i,j)
      !!                ncsi2(), ncsj2() : north-east Closed sea limits (i,j)
      !!                ncsir(), ncsjr() : Location of runoff
      !!                ncsnr            : number of point where run-off pours
      !!                ncstt            : Type of closed sea
      !!                                   =0 spread over the world ocean
      !!                                   =2 put at location runoff
      !!----------------------------------------------------------------------
      INTEGER ::   jc      ! dummy loop indices
      INTEGER ::   isrow   ! local index
      !!----------------------------------------------------------------------
      !
      IF(lwp) WRITE(numout,*)
      IF(lwp) WRITE(numout,*)'dom_clo : closed seas '
      IF(lwp) WRITE(numout,*)'~~~~~~~'
      !
      ! initial values
      ncsnr(:) = 1  ;  ncsi1(:) = 1  ;  ncsi2(:) = 1  ;  ncsir(:,:) = 1
      ncstt(:) = 0  ;  ncsj1(:) = 1  ;  ncsj2(:) = 1  ;  ncsjr(:,:) = 1
      !
      ! set the closed seas (in data domain indices)
      ! -------------------
      !
      IF( cp_cfg == "orca" ) THEN
         !
         SELECT CASE ( jp_cfg )
         !                                           ! =======================
         CASE ( 1 )                                  ! ORCA_R1 configuration
            !                                        ! =======================
            ! This dirty section will be suppressed by simplification process:
            ! all this will come back in input files
            ! Currently these hard-wired indices relate to configuration with
            ! extend grid (jpjglo=332)
            isrow = 332 - jpjglo
            !
            ncsnr(1)   = 1    ; ncstt(1)   = 0           ! Caspian Sea
            ncsi1(1)   = 332  ; ncsj1(1)   = 243 - isrow
            ncsi2(1)   = 344  ; ncsj2(1)   = 275 - isrow
            ncsir(1,1) = 1    ; ncsjr(1,1) = 1
            !
            !                                        ! =======================
         CASE ( 2 )                                  !  ORCA_R2 configuration
            !                                        ! =======================
            !                                            ! Caspian Sea
            ncsnr(1)   =   1  ;  ncstt(1)   =   0           ! spread over the globe
            ncsi1(1)   =  11  ;  ncsj1(1)   = 103
            ncsi2(1)   =  17  ;  ncsj2(1)   = 112
            ncsir(1,1) =   1  ;  ncsjr(1,1) =   1
            !                                            ! Great North American Lakes
            ncsnr(2)   =   1  ;  ncstt(2)   =   2           ! put at St Laurent mouth
            ncsi1(2)   =  97  ;  ncsj1(2)   = 107
            ncsi2(2)   = 103  ;  ncsj2(2)   = 111
            ncsir(2,1) = 110  ;  ncsjr(2,1) = 111
            !                                            ! Black Sea (crossed by the cyclic boundary condition)
            ncsnr(3:4) =   4  ;  ncstt(3:4) =   2           ! put in Med Sea (north of Aegean Sea)
            ncsir(3:4,1) = 171;  ncsjr(3:4,1) = 106         !
            ncsir(3:4,2) = 170;  ncsjr(3:4,2) = 106
            ncsir(3:4,3) = 171;  ncsjr(3:4,3) = 105
            ncsir(3:4,4) = 170;  ncsjr(3:4,4) = 105
            ncsi1(3)   = 174  ;  ncsj1(3)   = 107           ! 1 : west part of the Black Sea
            ncsi2(3)   = 181  ;  ncsj2(3)   = 112           !            (ie west of the cyclic b.c.)
            ncsi1(4)   =   2  ;  ncsj1(4)   = 107           ! 2 : east part of the Black Sea
            ncsi2(4)   =   6  ;  ncsj2(4)   = 112           !           (ie east of the cyclic b.c.)

            !                                        ! =======================
         CASE ( 4 )                                  !  ORCA_R4 configuration
            !                                        ! =======================
            !                                            ! Caspian Sea
            ncsnr(1)   =  1  ;  ncstt(1)   =  0
            ncsi1(1)   =  4  ;  ncsj1(1)   = 53
            ncsi2(1)   =  4  ;  ncsj2(1)   = 56
            ncsir(1,1) =  1  ;  ncsjr(1,1) =  1
            !                                            ! Great North American Lakes
            ncsnr(2)   =  1  ;  ncstt(2)   =  2
            ncsi1(2)   = 49  ;  ncsj1(2)   = 55
            ncsi2(2)   = 51  ;  ncsj2(2)   = 56
            ncsir(2,1) = 57  ;  ncsjr(2,1) = 55
            !                                            ! Black Sea
            ncsnr(3)   =  4  ;  ncstt(3)   =  2
            ncsi1(3)   = 88  ;  ncsj1(3)   = 55
            ncsi2(3)   = 91  ;  ncsj2(3)   = 56
            ncsir(3,1) = 86  ;  ncsjr(3,1) = 53
            ncsir(3,2) = 87  ;  ncsjr(3,2) = 53
            ncsir(3,3) = 86  ;  ncsjr(3,3) = 52
            ncsir(3,4) = 87  ;  ncsjr(3,4) = 52
            !                                            ! Baltic Sea
            ncsnr(4)   =  1  ;  ncstt(4)   =  2
            ncsi1(4)   = 75  ;  ncsj1(4)   = 59
            ncsi2(4)   = 76  ;  ncsj2(4)   = 61
            ncsir(4,1) = 84  ;  ncsjr(4,1) = 59
            !                                        ! =======================
         CASE ( 025 )                                ! ORCA_R025 configuration
            !                                        ! =======================
            ncsnr(1)   = 1    ; ncstt(1)   = 0               ! Caspian + Aral sea
            ncsi1(1)   = 1330 ; ncsj1(1)   = 645
            ncsi2(1)   = 1400 ; ncsj2(1)   = 795
            ncsir(1,1) = 1    ; ncsjr(1,1) = 1
            !
            ncsnr(2)   = 1    ; ncstt(2)   = 0               ! Azov Sea
            ncsi1(2)   = 1284 ; ncsj1(2)   = 722
            ncsi2(2)   = 1304 ; ncsj2(2)   = 747
            ncsir(2,1) = 1    ; ncsjr(2,1) = 1
            !
         END SELECT
         !
      ENDIF

      ! convert the position in local domain indices
      ! --------------------------------------------
      DO jc = 1, jpncs
         ncsi1(jc)   = mi0( ncsi1(jc) )
         ncsj1(jc)   = mj0( ncsj1(jc) )

         ncsi2(jc)   = mi1( ncsi2(jc) )
         ncsj2(jc)   = mj1( ncsj2(jc) )
      END DO
      !
   END SUBROUTINE dom_clo

   SUBROUTINE clo_bat( pbat, kbat )
      !!---------------------------------------------------------------------
      !!                  ***  ROUTINE clo_bat  ***
      !!
      !! ** Purpose :   suppress closed sea from the domain
      !!
      !! ** Method  :   set to 0 the meter and level bathymetry (given in
      !!                arguments) over the closed seas.
      !!
      !! ** Action  :   set pbat=0 and kbat=0 over closed seas
      !!----------------------------------------------------------------------
      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pbat   ! bathymetry in meters (bathy array)
      INTEGER , DIMENSION(jpi,jpj), INTENT(inout) ::   kbat   ! bathymetry in levels (mbathy array)
      !
      INTEGER  ::   jc, ji, jj      ! dummy loop indices
      !!----------------------------------------------------------------------
      !
      DO jc = 1, jpncs
         DO jj = ncsj1(jc), ncsj2(jc)
            DO ji = ncsi1(jc), ncsi2(jc)
               pbat(ji,jj) = 0._wp
               kbat(ji,jj) = 0
            END DO
         END DO
       END DO
       !
   END SUBROUTINE clo_bat

   !!======================================================================
END MODULE closea


       subroutine get_camera_clouds(minalt,maxalt,minazi,maxazi,alt_scale,azi_scale, & ! I
                                    i4time,fname_ppm,mode, &                           ! I
                                    mask_cyl,istatus)                                  ! O

       use ppm

       parameter (nip = 511)
       parameter (njp = 511)

       integer mask_cyl(minalt:maxalt,minazi:maxazi)  ! O
                                                      ! 0 means unknown
                                                      ! 1 means clear
                                                      ! 2 means cloud
       integer image(minalt:maxalt,minazi:maxazi) ! L
       integer img_polar(3,511,511)
       integer mask_polar(511,511)
       integer, allocatable :: img(:,:,:)
       integer u /12/

       character*255 imgfile,img_png,img_ppm,convert_cmd,camera_path
       character*13 a13name, cvt_i4time_wfo_fname13
       character*9 a9time
       character*10 fname_ppm

!      Statement functions
       i2ialt(i) = minalt+i-1
       altf(ialt) = (ialt-minalt) * alt_scale

       j2jazi(i) = minazi+j-1
       azif(jazi) = (jazi-minazi) * azi_scale

!      Executable statements
       camera_path = '.' ! not needed for mode=2
       mask_cyl = 0

       a13name = cvt_i4time_wfo_fname13(i4time)
       call make_fnam_lp(i4time,a9time,istatus)

       if(.false.)then      ! Read polar observed image in PPM format

         imgfile = '/w3/lapb/allsky/sites/dsrc/output3'//'/'//a13name//'_dsrc.ppm'

         open(u,file=trim(imgfile),status='old',err=999)
         read(u,*)
         read(u,*)iwidth,iheight
         rewind(u)
         write(6,*)' dynamic dims ',ncol,iwidth,iheight
         allocate(img(ncol,iwidth,iheight))
         call read_ppm(u,img,ncol,iwidth,iheight)
         close(u)
         write(6,*)' polar image has been read in'

       elseif(.false.)then ! Read cyl observed image in PPM format
                           ! (remapped to alt/az grid)

         imgfile = '/w3/lapb/allsky/sites/dsrc/output3c'//'/'//a13name//'_dsrc.ppm'

         open(u,file=trim(imgfile),status='old',err=999)
         read(u,*)
         read(u,*)iwidth,iheight
         rewind(u)
         write(6,*)' dynamic dims ',ncol,iwidth,iheight
         allocate(img(ncol,iwidth,iheight))
         call read_ppm(u,img,ncol,iwidth,iheight)
         close(u)
         write(6,*)' cyl image has been read in'

       elseif(mode .eq. 1)then ! Read polar (contingency table) mask
         img_png = trim(camera_path)//'/verif_allsky_mask.dsrc.'//a9time//'.png'
         img_ppm = trim(camera_path)//'/verif_allsky_mask.dsrc.'//a9time//'.ppm'

         convert_cmd = 'convert -compress none '//trim(img_png)//' '//trim(img_ppm)
         write(6,*)trim(convert_cmd)
         call system(trim(convert_cmd))

         open(u,file=trim(img_ppm),status='old',err=999)
         read(u,*)
         read(u,*)iwidth,iheight
         rewind(u)
         write(6,*)' dynamic dims ',ncol,iwidth,iheight
         ncol = 3
         call read_ppm(u,img_polar,ncol,iwidth,iheight)
         close(u)
         write(6,*)' polar mask has been read into img_polar array'

         do ic = 1,ncol
           write(6,*)
           write(6,*)' polar view for color ',ic
           do j = 1,nip,25
             write(6,21)ic,j,img_polar(ic,1:nip:25,j)
21           format(30i4)
           enddo ! j
         enddo ! ic

!        Convert to camera cloud mask image
         do i = 1,nip
         do j = 1,njp
             if(img_polar(3,i,j) .gt. 200)then
                 mask_polar(i,j) = 2 ! cloud
             elseif(img_polar(3,i,j) .eq. 255)then
                 mask_polar(i,j) = 1 ! clear
             else
                 mask_polar(i,j) = 0 ! unknown
             endif
         enddo ! j
         enddo ! i

         do j = 1,njp,10
             write(6,*)
             write(6,*)' polar categorical mask'
             write(6,31)j,mask_polar(1:nip:6,j)
31           format(1x,i3,1x,100i1)
         enddo ! j

         write(6,*)' Sum of mask_polar is ',sum(mask_polar)

!        Convert to cylindrical image
         write(6,*)' Projecting to Cylindrical Mask'
         call polar_to_cyl(mask_polar,mask_cyl,nip,njp,minalt,maxalt,minazi,maxazi,alt_scale,azi_scale)

       elseif(mode .eq. 2)then ! Read cyl mask (if produced by IDL code)
         if(.false.)then
           img_png = trim(camera_path)//'/camera_allsky_mask.dsrc.'//a9time//'.png'
           img_ppm = trim(camera_path)//'/camera_allsky_mask.dsrc.'//a9time//'.ppm'

           convert_cmd = 'convert -compress none '//trim(img_png)//' '//trim(img_ppm)
           write(6,*)trim(convert_cmd)
           call system(trim(convert_cmd))
           open(u,file=trim(img_ppm),status='old',err=999)
         else
           write(6,*)' Opening ',trim(fname_ppm)
           open(u,file=trim(fname_ppm),status='old',err=999)
         endif

         read(u,*)
         read(u,*)iwidth,iheight
         rewind(u)
         ncol = 3
         write(6,*)' dynamic dims ',ncol,iwidth,iheight
         call read_ppm(u,img_polar,ncol,iwidth,iheight)
         close(u)
         write(6,*)' polar mask has been read into img_polar array'

         do ic = 1,ncol
           write(6,*)
           do j = 1,nip,25
             write(6,21)ic,j,img_polar(ic,1:nip:25,j)
           enddo ! j
         enddo ! ic

!        Convert to camera cloud mask image
         do i = 1,nip
         do j = 1,njp
             if(img_polar(1,i,j) .gt. 200)then
                 mask_polar(i,j) = 2 ! cloud
             elseif(img_polar(1,i,j) .eq. 0)then
                 mask_polar(i,j) = 1 ! clear
             else
                 mask_polar(i,j) = 0 ! unknown
             endif
         enddo ! j
         enddo ! i

         do j = 1,njp,10
             write(6,31)j,mask_polar(1:nip:6,j)
         enddo ! j

         write(6,*)' Sum of mask_polar is ',sum(mask_polar)

!        Convert to cylindrical image
         write(6,*)' Projecting to Cylindrical Mask'
         call polar_to_cyl(mask_polar,mask_cyl,nip,njp,minalt,maxalt,minazi,maxazi,alt_scale,azi_scale)

       endif

!      Mask out label at the top or clone nearby data (a small distance)

!      Mask out horizon area

!      Apply cloud algorithm
       do ialt = minalt,maxalt
       do jazi = minazi,maxazi
       enddo ! jazi
       enddo ! ialt

       istatus = 1
       write(6,*)' success in get_camera_clouds'
       return

999    istatus = 0
       write(6,*)' ERROR opening image file in read_camera_clouds'
       return

       end

       subroutine polar_to_cyl(img_p,img_c,nip,njp,minalt,maxalt,minazi,maxazi,alt_scale,azi_scale)

       include 'trigd.inc'

       integer img_p(nip,njp)
       integer img_c(minalt:maxalt,minazi:maxazi)

!      write(6,*)' sum of input polar is ',sum(img_p)

       img_c = 0

!      Loop through cylindrical array
       do ialt = minalt,maxalt
       do jazi = minazi,maxazi

!          Determine altitude and azimuth
           alt_d = float(ialt) * alt_scale
           azi_d = float(jazi) * azi_scale

!          Calculate Polar Image Coordinates (zero azimuth is up)
           ipcen = 256
           jpcen = 256
           radius = 255. * (90. - alt_d)/90.

           rip = float(ipcen) - sind(azi_d) * radius
           rjp = float(jpcen) - cosd(azi_d) * radius

           ip = nint(rip)
           jp = nint(rjp)

!          write(6,*)ialt,jazi,ip,jp,img_p(ip,jp)
           img_c(ialt,jazi) = img_p(ip,jp)

       enddo ! jazi
       enddo ! ialt

       return
       end