!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Ole Amund Sovde, April 2015
!//=========================================================================
!// Nitrate aerosols.
!//=========================================================================
module nitrate
  !// ----------------------------------------------------------------------
  !// MODULE: nitrate.
  !// DESCRIPTION: Contains routines for treating nitrate aerosols,
  !//              currently with equlibrium model eqsam.
  !//
  !// Contains
  !//   subroutine nitrate_init
  !//   subroutine nitrate_master
  !//
  !// Should add output diagnostics here.
  !//
  !// To f90 and Oslo CTM3
  !// Ole Amund Sovde, November 2009
  !// ----------------------------------------------------------------------
  use cmn_precision, only: r8
  use cmn_size, only:LPAR, IDBLK, JDBLK, MPBLK
  !// ----------------------------------------------------------------------
  implicit none
  !// ----------------------------------------------------------------------

  !// The fine and coarse mode of H2O were only used in diagnostics (3-hourly
  !// output) and should not need to be transported. Treat them privately in
  !// this module until otherwise is needed.
  !// H2Ofine (component 78) and H2Ocoarse (component 79).
  real(r8), dimension(LPAR,IDBLK,JDBLK,MPBLK) :: H2Ofine, H2Ocoarse
  !// ----------------------------------------------------------------------
  character(len=*), parameter, private :: f90file = 'nitrate.f90'
  !// ----------------------------------------------------------------------
  save !// All variables are to be saved.
  private
  public nitrate_init, nitrate_master
  !// ----------------------------------------------------------------------

contains

  !// ----------------------------------------------------------------------
  subroutine nitrate_init(trsp_idx,TRACER_ID_MAX,LSULFUR,LSALT)
    !// --------------------------------------------------------------------
    !// Check that all species needed to run NITRATE are included.
    !//
    !// Ole Amund Sovde, November 2009
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    integer, intent(in) :: TRACER_ID_MAX, trsp_idx(TRACER_ID_MAX)
    logical, intent(in) :: LSULFUR, LSALT
    !// --------------------------------------------------------------------
    character(len=*), parameter :: subr = 'nitrate_init'
    !// --------------------------------------------------------------------

    !// Check for needed packages to run NITRATE
    if ( (.not. LSULFUR) .or. (.not. LSALT) &
         .or. trsp_idx(73).lt.0 .or. trsp_idx(61).lt.0 &
         .or. trsp_idx(62).lt.0 .or. trsp_idx(63).lt.0 &
         .or. trsp_idx(64).lt.0 .or. trsp_idx(65).lt.0 ) then

       write(6,'(a)') f90file//':'//subr//': MISSING data for NITRATE run'
       if (.not.LSULFUR) write(6,'(a)') '  * Sulphur module must be turned on'
       if (.not.LSALT)   write(6,'(a)') '  * Salt module must be turned on'
       if (trsp_idx(73).lt.0 .or. trsp_idx(61).lt.0 .or. trsp_idx(62).lt.0 &
            .or. trsp_idx(63).lt.0 .or. trsp_idx(64).lt.0 &
            .or. trsp_idx(65).lt.0) then
          write(6,'(a)') 'Check that species 73, 61, 62, 63, 64, 65 are included'
          write(6,'(a)') ' i.e. SULPHUR and SALT packages.'
          write(6,'(a)') 'Species MUST be transported!'
          stop
       end if

    end if
    !// --------------------------------------------------------------------
  end subroutine nitrate_init
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine nitrate_master(BTT, &   !I/O [kg] tracer in box
                            BTEM, &  !I [K] Temperature
                            QHUM, &  !I [kg/kg] absolute humidity
                            BDV, &   !I [m3] volume of grid box
                            AIRB, &  !I [kg] air mass in grid box
                            MP )
    !// --------------------------------------------------------------------
    !// Based on CTM2 routine metzgerequil.
    !//
    !// Purpose: Given a total conenctration of inorganic species
    !// Put this concentration in equilibrium between gas and aerosol phase

    !// Calls EQSAM
    !// Reference: http:/www.mpch-mainz.mpg.de/~metzger

    !// Note that the way this is written assumes that you have given the
    !// right molecular weight of sea salt in input file. Early model runs of
    !// seasalt used molar weight of seasalt= molar weight of air so that
    !// mixing ratio (mass) and (volume) are equal. That is just to simplify
    !// since CTM outputs mixing ratio (volume) and we really want to have
    !// seasalt mixing ratio (mass). For these runs, this has changed.
    !// Make sure you know what you do...
    !//
    !// To Oslo CTM3
    !// Ole Amund Sovde, November 2009
    !// --------------------------------------------------------------------
    use cmn_size, only: IPAR, JPAR, NPAR, IDBLK, JDBLK, LOSLOCSTRAT
    use cmn_ctm, only: MPBLKJB, MPBLKJE, MPBLKIB, MPBLKIE
    use cmn_chem, only: TMASS
    use cmn_parameters, only: R_UNIV
    use cmn_oslo, only: trsp_idx, LMTROP, LVS2ADD2TC
    use seasalt, only: Nsaltbins, salt_trsp_idx
    use eqsam_v03d, only: eqsam_v03d_sub  !Use the eqsam module
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    real(r8), intent(in) :: &
         BTEM(LPAR,IDBLK,JDBLK), &
         AIRB(LPAR,IDBLK,JDBLK), &
         BDV(LPAR,IDBLK,JDBLK), &
         QHUM(IPAR,JPAR,LPAR)
    integer, intent(in) :: MP !// IJ-block
    !// In/Out [kg]
    real(r8), intent(inout) :: BTT(LPAR,NPAR,IDBLK,JDBLK)

    !// Parameters needed to get Relative humidity.
    !// Coefficients used to calculate saturation partial pressure of water
    !// at a certain temperature (Seinfeld & Pandis, atmospheric chemistry
    !// and physics pp 781, table 15.2)
    real(r8), parameter :: a0 = 6.1078_r8
    real(r8), parameter :: a1 = 4.4365e-1_r8
    real(r8), parameter :: a2 = 1.4289e-2_r8
    real(r8), parameter :: a3 = 2.6507e-4_r8
    real(r8), parameter :: a4 = 3.0312e-6_r8
    real(r8), parameter :: a5 = 2.0341e-8_r8
    real(r8), parameter :: a6 = 6.1368e-11_r8

    !// Parameters needed for calling Metzger's code
    integer, parameter  :: nca = 11         !Size of input array
    integer, parameter  :: nco = 35         !Size of output array

    !// LOCAL
    !// Dimensaions are really included in isrpia.inc, but I rename them here
    !// So that this code is really decoupled from ISORROPIA
    real(r8)  :: &
         TEMP(LPAR), &
         mol2umolm3(LPAR), &   !Conversion mol->umol/m3
         RH(LPAR)              !Relative humidity
    real(r8)  :: yi(LPAR,nca)    !Input, mostly in umol/m3
    real(r8)  :: yo(LPAR,nco)    !Output in umol/m3
    integer :: &
         idx_cmp, &      !Counter for salt component
         I,J,II,JJ,L, &  !Loop counters
         TNR, &          !Temprary number
         iopt, &         !Indication for solid/liquid/metastable aerosol
         imode, &        !Loop ixd for aerosol modes
         in(6)           !Needed by EQSAM, don't know what it is good for.
    real(r8) :: &
         P0, &           ![Pa] saturation water pressure
         TC, &           ![degree C] temperature
         weightvapor, &  ![kg] weight of vapor in grid cell
         pvapor          ![Pa] Partial pressure of vapor in grid cell
    real(r8)  :: LOSS, LOSSFRAC !// To remove in stratospheric
    integer :: LMAX !// Integrate nitrate module up to this level

    !// Local parameter
    real(r8), parameter :: ZEROVAL = 1.e-20_r8
    !// Flag for writing a lot of things
    logical,parameter :: Ldebug_nit = .false.
    !// --------------------------------------------------------------------
    character(len=*), parameter :: subr = 'nitrate_master'
    !// --------------------------------------------------------------------

    !// We want metastable aerosols
    iopt = 1

    !// Loop over latitude (J is global, JJ is block)
    do J = MPBLKJB(MP), MPBLKJE(MP)
       JJ    = J - MPBLKJB(MP) + 1

       !// CTM2 does nitrate only up to max LMTROP in latitude band
       !// The same applies for sulphate.
       LMAX = maxval(LMTROP(:,J)) + LVS2ADD2TC

       !// IMPORTANT!
       !// Above LMAX, in the stratosphere, we may assume there is sulphate
       !// presenent, so NH4NO3 should be converted to HNO3. The SO4 tracer
       !// should _not_ be increased, because SO4 is never removed in the
       !// formation of (NH4)2SO4.
       !// This treatment should be included below I-loop or at the bottom,
       !// for NO3fine and NO3coarse.

       !// Loop over longitude (I is global, II is block)
       do I = MPBLKIB(MP), MPBLKIE(MP)
          II    = I - MPBLKIB(MP) + 1

          !// Tropopause height when using stratospheric chemistry
          if (LOSLOCSTRAT) LMAX = LMTROP(I,J)

          !// Set some variables for the vertical
          !// ------------------------------------------------------------------
          do L = 1, LMAX !// Do not calculate nitrate in stratosphere

             !// Conversion from mass to umol/m3
             !// DV is m3, mass is kg
             !// CONC = MASS * 1.d3 [g] / TMASS [g/mol] * 1.d6 [umol/mol]
             !//                / DV [m3]
             !// 1.d9 = 1.d3 (g/kg) * 1.d6 (umol/mol)
             mol2umolm3(L) = 1.e9_r8 / BDV(L,II,JJ)

             !// Temperature
             TEMP(L) = BTEM(L,II,JJ)

             !// Relative humidity
             TC = BTEM(L,II,JJ) - 273.15_r8
             if (Ldebug_nit) write(6,*) 'TC', TC

             !// Saturation water pressure [hPa]
             P0 = a0 + a1*TC + a2*TC*TC + a3*TC**3 + a4*TC**4 &
                     + a5*TC**5 + a6*TC**6
             P0 = P0 * 1.e2_r8 !// convert to Pa

             if (Ldebug_nit) then
                write(6,*)'P0',P0
                write(6,*)'Q ',L,QHUM(I,J,L)
                write(6,*)'AIR',L,AIRB(L,II,JJ)
             end if

             !// weight of H2O (in kg)
             weightvapor = QHUM(I,J,L) * AIRB(L,II,JJ)
             if (Ldebug_nit) write(6,*) 'weightvapor', weightvapor

             !// Partial pressure of H2O using ideal gas (pV=nRT)
             pvapor = (weightvapor * 1.e3_r8 / 18.02_r8) * R_UNIV &
                  * BTEM(L,II,JJ) / BDV(L,II,JJ)
             if (Ldebug_nit) write(6,*) 'Pvapor', pvapor

             !// Relative humidity
             RH(L) = Pvapor / P0        !RELATIVE HUMIDITY
             if (RH(L) .gt. 1._r8) then
                RH(L) = 1._r8
             else if (RH(L) .lt. 0._r8) then
                RH(L) = 0.01_r8
             end if
             if (Ldebug_nit) write(6,*) 'Relative humidity ', L, RH(L)

             !// Don't do calculation if T (degrees C) < -50
             IF (TC .lt. -50._r8) RH(L) = 0._r8

          end do !// do L = 1, LMAX

          !// Set variables independent of mode
          do L = 1, LMAX !// Do not calculate nitrate in stratosphere

             !// Get the temperature (Kelvin)
             yi(L,1) = TEMP(L)

             !// Get the relative humidity
             yi(L,2) = RH(L)

             !// Get the total pressure ! NOT USED; send in a random number
             yi(L,11) = 1.e3_r8        !hPa

          end do !// do L = 1, LMAX

          !// Loop over fine and coarse mode
          !// --------------------------------------------------------------
          do imode = 1, 2

             select case(imode)

             case(1)
                !// FINE MODE
                !// --------------------------------------------------------
                do L = 1, LMAX !// Do not calculate nitrate in stratosphere

                   !// Natrium content
                   yi(L,6) = 0._r8        !No natrium

                   !// Chloride content
                   yi(L,7) = 0._r8        !No chloride

                   !// Sulfate content (mass, must be converted to umolec/m3)
                   !// Total sulfate,  convert from mass to mole
                   yi(L,4) = BTT(L,trsp_idx(73),II,JJ)  / TMASS(trsp_idx(73)) &
                        * mol2umolm3(L)

                   !// Ammonia/ammonium content (total gas NH3 (tracer 61)
                   !// + fine NH4 (tracer 62)). Convert to correct mole
                   !// fraction.
                   yi(L,3) = ( BTT(L,trsp_idx(61),II,JJ)/TMASS(trsp_idx(61)) &
                             + BTT(L,trsp_idx(62),II,JJ)/TMASS(trsp_idx(62)) ) &
                             * mol2umolm3(L)

                   !// Nitrate content (Total HNO3 gas (4) + fine NO3 (64))
                   !// Convert to correct mole fraction.
                   yi(L,5) = ( BTT(L,trsp_idx(4),II,JJ)/TMASS(trsp_idx(4)) &
                             + BTT(L,trsp_idx(64),II,JJ)/TMASS(trsp_idx(64)) ) &
                             * mol2umolm3(L)

                   !// Set Kalium (K+), Calsium (Ca++) and Magnesium (Mg++)
                   !// to zero
                   yi(L,8) = 0._r8
                   yi(L,9) = 0._r8
                   yi(L,10)= 0._r8

                end do !// do L = 1, LMAX

             case(2)
                !// COARSE MODE
                !// --------------------------------------------------------
                do L = 1, LMAX !// Do not calculate nitrate in stratosphere

                   !// Get Natrium
                   yi(L,6) = 0._r8
                   !// Fetch Natrium from salt species (mass; convert to
                   !// umolec/m3). Total Na (Assume equal ammounts of Na & Cl)
                   do idx_cmp = 1, Nsaltbins
                      !// Sum up all salt species
                      TNR = salt_trsp_idx(idx_cmp)
                      yi(L,6) = yi(L,6)  &
                           + BTT(L,TNR,II,JJ)/TMASS(TNR) * mol2umolm3(L)
                   end do

                   !// Chloride equals natrium (assume molar ratio of 1:1
                   !// in seasalt for Na and Cl)
                   yi(L,7) = yi(L,6)

                   !// Sulfate (we assume none in coarse mode)
                   yi(L,4) = 0._r8

                   !// Gas NH3 and coarse NH4 (Total NH3gas (61)
                   !// + coarse NH4 (63))
                   yi(L,3) = ( BTT(L,trsp_idx(61),II,JJ)/TMASS(trsp_idx(61)) &
                             + BTT(L,trsp_idx(63),II,JJ)/TMASS(trsp_idx(63)) ) &
                             * mol2umolm3(L)

                   !// Gas and coarse nitrate (Total HNO3 gas (4)
                   !// + coarse NO3 (65))
                   yi(L,5) = ( BTT(L,trsp_idx(4),II,JJ)/TMASS(trsp_idx(4)) &
                             + BTT(L,trsp_idx(65),II,JJ)/TMASS(trsp_idx(65)) ) &
                             * mol2umolm3(L)

                   !// Set Kalium (K+), Calsium (Ca++) and Magnesium (Mg++)
                   !// to zero
                   yi(L,8) = 0._r8
                   yi(L,9) = 0._r8
                   yi(L,10)= 0._r8

                end do !// do L = 1, LMAX

             case default
                write(6,'(a,i7)') f90file//':'//subr// &
                     ': error in IMODE parameter',IMODE
                stop
             end select

             !// write(6,*)'eqs calling eqsam for ICOARSE=',ICOARSE
             !// write(6,'(a,(32e10.3))')'so4',yi(:,4)
             !// write(6,'(a,(32e10.3))')'HNO3',yi(:,5)
             !// write(6,'(a,(32e10.3))')'NH4',yi(:,3)
             !// write(6,'(a,(32e10.3))')'salt',yi(:,6)

             !// CALL EQSAM (NOTE: DOUBLE PRECISION FOR ALL INPUTS)
             !// -----------------------------------------------------------
             call eqsam_v03d_sub( &
                  yi, &       !I input concentrations (umol/m3)
                  yo, &       !O output concentrations (umol/m3)
                  nca, &      !I Number of input parameters
                  nco, &      !I Number of output parameters
                  iopt, &     !I Option (normally 1 for metastable)
                  LMAX, &     !I Number of steps to perform
                  LPAR, &     !I Size of input/output blocks
                  6, &        !I Unit to write to (screen)
                  in )        !I Don't know what this is good for

             !// write(6,'(a,4e15.3)')  'eqs hno3(a)/nh4(a)/hno3(g)/nh4(g)', &
             !//     yo(:,20),yo(:,19),yo(:,9),yo(:,10)

             !// write(6,'(a,4e15.3)') 'eqs checking output, NH3',&
             !//     yo(:,3),yo(:,19),yo(:,16),yo(:,10)

             !// write(6,'(a,4e15.3)') 'eqs checking output, HNO3', &
             !//     yo(:,5),yo(:,20),yo(:,17),yo(:,9)

             !// Put back into BTT (mass, must convert from umol/m3)
             !// -----------------------------------------------------------
             select case(imode)

             case(1)
                !// FINE MODE
                !// --------------------------------------------------------
                do L = 1, LMAX !// Do not calculate nitrate in stratosphere

                   !// Fine mode ammonium (NH4+ and NH3(aq)). Back to mass.
                   BTT(L,trsp_idx(62),II,JJ) = max(ZEROVAL, &
                        yo(L,19) * TMASS(trsp_idx(62))/mol2umolm3(L) )

                   !// Fine mode nitrate (aerosol HNO3). Back to mass.
                   BTT(L,trsp_idx(64),II,JJ) = max(ZEROVAL, &
                        yo(L,20) * TMASS(trsp_idx(64))/mol2umolm3(L) )

                   !// Gas HNO3 left after equil. with fine mode. Back to mass.
                   BTT(L,trsp_idx(4),II,JJ) = max(ZEROVAL, &
                        yo(L,9) * TMASS(trsp_idx(4))/mol2umolm3(L) )

                   !// Gas NH3 left after equil. with fine mode. Back to mass.
                   BTT(L,trsp_idx(61),II,JJ) = max(ZEROVAL, &
                        yo(L,10) * TMASS(trsp_idx(61))/mol2umolm3(L) )

                   !// Water; (NOTE: H2O is in ugram in Metzger's code)
                   !// Not transported, only for diagnostics
                   H2Ofine(L,II,JJ,MP) = max(ZEROVAL, yo(L,12)/mol2umolm3(L))

                end do !// do L = 1, LMAX

             case(2)
                !// COARSE MODE
                !// --------------------------------------------------------
                do L = 1, LMAX !// Do not calculate nitrate in stratosphere

                   !// Coarse ammonium (NH4+ and NH3(aq))
                   BTT(L,trsp_idx(63),II,JJ) = max(ZEROVAL, &
                        yo(L,19) * TMASS(trsp_idx(63))/mol2umolm3(L) )

                   !// Coarse nitrate (NO3- & HNO3(aq))
                   BTT(L,trsp_idx(65),II,JJ) = max(ZEROVAL, &
                        yo(L,20) * TMASS(trsp_idx(65))/mol2umolm3(L) )

                   !// Gas HNO3 left after equilibrium with coarse
                   BTT(L,trsp_idx(4),II,JJ) = max(ZEROVAL, &
                        yo(L,9) * TMASS(trsp_idx(4))/mol2umolm3(L) )

                   !// Gas NH3 left after equilibrium with coarse mode
                   BTT(L,trsp_idx(61),II,JJ) = max(ZEROVAL, &
                        yo(L,10) * TMASS(trsp_idx(61))/mol2umolm3(L) )

                   !// Water; (NOTE: H2O is in ugram/m3 in Metzger's code)
                   !// Not transported, only for diagnostics
                   H2Ocoarse(L,II,JJ,MP) = max(ZEROVAL, yo(L,12)/mol2umolm3(L))

                end do !// do L = 1, LMAX

             case default
                write(6,'(a,i7)') f90file//':'//subr// &
                     ': error in coarse/fine indicator',IMODE
             end select

             !// write(6,*)'done equilibrium indicator',imode

          end do !// do imode = 1, 2

          !// Stratospheric treatment
          do L = LMAX+1, LPAR

             !// Assume 65% to be removed (roughly 1 hour life time)
             LOSSFRAC = 0.65_r8

             !// Remove NO3fine (64); assume it produces HNO3
             LOSS = BTT(L,trsp_idx(64),II,JJ) * LOSSFRAC
             BTT(L,trsp_idx(64),II,JJ) = max(ZEROVAL, &
                  BTT(L,trsp_idx(64),II,JJ) * (1._r8 - LOSSFRAC))

             !// Move to HNO3 & NOy
             if (LOSS .gt. ZEROVAL) then
                !// Convert from mass of NO3fine to mass of HNO3
                BTT(L,trsp_idx(4),II,JJ) = BTT(L,trsp_idx(4),II,JJ) &
                     + LOSS * TMASS(trsp_idx(4)) / TMASS(trsp_idx(64))
                !// Need to add to NOy also
                if (LOSLOCSTRAT) &
                     BTT(L,trsp_idx(147),II,JJ) = BTT(L,trsp_idx(147),II,JJ) &
                     + LOSS * TMASS(trsp_idx(147)) / TMASS(trsp_idx(64))
             end if

             !// Remove NO3coarse (65); assume it produces HNO3
             LOSS = BTT(L,trsp_idx(65),II,JJ) * LOSSFRAC
             BTT(L,trsp_idx(65),II,JJ) = max(ZEROVAL, &
                  BTT(L,trsp_idx(65),II,JJ) * (1._r8 - LOSSFRAC))

             !// Move to HNO3 & NOy
             if (LOSS .gt. ZEROVAL) then
                !// Convert from mass of NO3coarse to mass of HNO3
                BTT(L,trsp_idx(4),II,JJ) = BTT(L,trsp_idx(4),II,JJ) &
                     + LOSS * TMASS(trsp_idx(4)) / TMASS(trsp_idx(65))
                !// Need to add to NOy also
                if (LOSLOCSTRAT) &
                     BTT(L,trsp_idx(147),II,JJ) = BTT(L,trsp_idx(147),II,JJ) &
                     + LOSS * TMASS(trsp_idx(147)) / TMASS(trsp_idx(65))
             end if

             !// Remove NH4fine and NH4coarse
             BTT(L,trsp_idx(62),II,JJ) = &
                  max(ZEROVAL, BTT(L,trsp_idx(62),II,JJ) * (1._r8 - LOSSFRAC))
             BTT(L,trsp_idx(63),II,JJ) = &
                  max(ZEROVAL, BTT(L,trsp_idx(63),II,JJ) * (1._r8 - LOSSFRAC))

          end do

       end do !// do I = MPBLKIB(MP), MPBLKIE(MP)
    end do !// do J = MPBLKJB(MP), MPBLKJE(MP)

    !// --------------------------------------------------------------------
  end subroutine nitrate_master
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
end module nitrate
!//=========================================================================


      SUBROUTINE phrtsd(phrase,seed1,seed2)
C**********************************************************************
C
C     SUBROUTINE PHRTSD( PHRASE, SEED1, SEED2 )
C               PHRase To SeeDs
C
C
C                              Function
C
C
C     Uses a phrase (character string) to generate two seeds for the RGN
C     random number generator.
C
C
C                              Arguments
C
C
C     PHRASE --> Phrase to be used for random number generation
C                         CHARACTER*(*) PHRASE
C
C     SEED1 <-- First seed for RGN generator
C                         INTEGER SEED1
C
C     SEED2 <-- Second seed for RGN generator
C                         INTEGER SEED2
C
C
C                              Note
C
C
C     Trailing blanks are eliminated before the seeds are generated.
C
C     Generated seed values will fall in the range 1..2^30
C     (1..1,073,741,824)
C
C**********************************************************************
C     .. Parameters ..
      CHARACTER*(*) table
      PARAMETER (table='abcdefghijklmnopqrstuvwxyz'//
     +          'ABCDEFGHIJKLMNOPQRSTUVWXYZ'//'0123456789'//
     +          '!@#$%^&*()_+[];:''"<>?,./')
      INTEGER twop30
      PARAMETER (twop30=1073741824)
C     ..
C     .. Scalar Arguments ..
      INTEGER seed1,seed2
      CHARACTER phrase* (*)
C     ..
C     .. Local Scalars ..
      INTEGER i,ichr,j,lphr
C     ..
C     .. Local Arrays ..
      INTEGER shift(0:4),values(5)
C     ..
C     .. External Functions ..
      INTEGER lennob
      EXTERNAL lennob
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC index,mod
C     ..
C     .. Data statements ..
      DATA shift/1,64,4096,262144,16777216/
C     ..
C     .. Executable Statements ..
      seed1 = 1234567890
      seed2 = 123456789
      lphr = lennob(phrase)
      IF (lphr.LT.1) RETURN
      DO 30,i = 1,lphr
          ichr = mod(index(table,phrase(i:i)),64)
          IF (ichr.EQ.0) ichr = 63
          DO 10,j = 1,5
              values(j) = ichr - j
              IF (values(j).LT.1) values(j) = values(j) + 63
   10     CONTINUE
          DO 20,j = 1,5
              seed1 = mod(seed1+shift(j-1)*values(j),twop30)
              seed2 = mod(seed2+shift(j-1)*values(6-j),twop30)
   20     CONTINUE
   30 CONTINUE
      RETURN

      END


C$Procedure ZZGFREL ( Private --- GF, geometric relation finder )

      SUBROUTINE ZZGFREL ( UDSTEP,   UDREFN,  UDQDEC,  UDCOND,
     .                     UDFUNC,   UDQREF,  RELATE,  REFVAL,
     .                     TOL,      ADJUST,  CNFINE,  MW,
     .                     NW,       WORK,    RPT,     UDREPI,
     .                     UDREPU,   UDREPF,  RPTPRE,  RPTSUF,
     .                     BAIL,     UDBAIL,  RESULT           )

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     This routine determines time intervals when the value of some
C     geometric quantity related to one or more objects and an observer
C     satisfies a user specified constraint within time intervals
C     specified by the window CNFINE.
C
C     Sister routine to ZZGFRELX. Copy any edits to ZZGFREL or ZZGFRELX
C     to the sister routine.
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     TIME
C     NAIF_IDS
C     FRAMES
C
C$ Keywords
C
C     EPHEMERIS
C     GEOMETRY
C     SEARCH
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'gf.inc'

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      INTEGER               NWREQ
      PARAMETER           ( NWREQ  = 5 )

      EXTERNAL              UDSTEP
      EXTERNAL              UDREFN
      EXTERNAL              UDQDEC
      EXTERNAL              UDCOND
      EXTERNAL              UDFUNC
      EXTERNAL              UDQREF
      CHARACTER*(*)         RELATE
      DOUBLE PRECISION      REFVAL
      DOUBLE PRECISION      TOL
      DOUBLE PRECISION      ADJUST
      DOUBLE PRECISION      CNFINE ( LBCELL : * )
      INTEGER               MW
      INTEGER               NW
      DOUBLE PRECISION      WORK ( LBCELL : MW, NW )
      LOGICAL               RPT
      EXTERNAL              UDREPI
      EXTERNAL              UDREPU
      EXTERNAL              UDREPF
      CHARACTER*(*)         RPTPRE ( * )
      CHARACTER*(*)         RPTSUF ( * )
      LOGICAL               UDBAIL
      LOGICAL               BAIL
      EXTERNAL              UDBAIL
      DOUBLE PRECISION      RESULT ( LBCELL : * )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     LBCELL     P   SPICELIB cell lower bound.
C     NWREQ      P   Minimum number of workspace windows.
C     UDSTEP     I   Name of the routine that computes and returns a
C                    time step.
C     UDREFN     I   Name of the routine that computes a refined time.
C     UDQDEC     I   Name of the routine that computes whether the
C                    geometric quantity is decreasing.
C     UDCOND     I   Name of the routine that computes the geometric
C                    condition with-respect-to the constraint.
C     UDFUNC     I   The routine that computes the geometric quantity of
C                    interest.
C     UDQREF     I   Name of the routine that resets the current value
C                    of REFVAL.
C     RELATE     I   Operator that either looks for an extreme value
C                    (max, min, local, absolute) or compares the
C                    geometric quantity value and a number.
C     REFVAL     I   Value used as reference for geometric quantity
C                    condition.
C     TOL        I   Convergence tolerance in seconds.
C     ADJUST     I   Allowed variation for absolute extremal
C                    geometric conditions.
C     CNFINE     I   Confinement schedule
C     MW         I   Size of workspace windows.
C     NW         I   Number of workspace windows.
C     WORK       I   Array containing workspace windows
C     RPT        I   Progress reporter on ( .TRUE.) or off ( .FALSE. )
C     UDREPI     I   Function that initializes progress reporting.
C     UDREPU     I   Function that updates the progress report.
C     UDREPF     I   Function that finalizes progress reporting.
C     RPTPRE     I   Progress reporter beginning message.
C     RPTSUF     I   Progress reporter ending message.
C     BAIL       I   Logical indicating program interrupt monitoring.
C     UDBAIL     I   Name of a routine that signals a program interrupt.
C     RESULT    I-O  SPICE window containing results.
C
C
C$ Detailed_Input
C
C     UDSTEP     the routine that computes a time step in an attempt to
C                find a transition of the state of the specified
C                coordinate. In the context of this routine's algorithm,
C                a "state transition" occurs where the coordinate value
C                changes from "decreasing" to "not decreasing" or vice
C                versa.
C
C                This routine relies on UDSTEP returning step sizes
C                small enough so that state transitions within the
C                confinement window are not overlooked.  There must
C                never be two roots A and B separated by less than
C                STEP, where STEP is the minimum step size returned by
C                UDSTEP for any value of ET in the interval [A, B].
C
C                The calling sequence for UDSTEP is:
C
C                   CALL UDSTEP ( ET, STEP )
C
C                where:
C
C                   ET      is the input start time from which the
C                           algorithm is to search forward for a state
C                           transition. ET is expressed as seconds past
C                           J2000 TDB. ET is a DOUBLE PRECISION number.
C
C                   STEP    is the output step size.  STEP indicates
C                           how far to advance ET so that ET and
C                           ET+STEP may bracket a state transition and
C                           definitely do not bracket more than one
C                           state transition.  STEP is a DOUBLE
C                           PRECISION number.  Units are TDB seconds.
C
C                If a constant step size is desired, the routine
C                GFSTEP may be used. This is the default option.
C
C     UDREFN     the routine that computes a refinement in the times
C                that bracket a transition point. In other words, once
C                a pair of times have been detected such that the system
C                is in different states at each of the two times, UDREFN
C                selects an intermediate time which should be closer to
C                the transition state than one of the two known times.
C                The calling sequence for UDREFN is:
C
C                   CALL UDREFN ( T1, T2, S1, S2, T )
C
C                where the inputs are:
C
C                   T1    a time when the system is in state S1.
C
C                   T2    a time when the system is in state S2. T2
C                         is assumed to be larger than T1.
C
C                   S1    a logical indicating the state of the system
C                         at time T1.
C
C                   S2    a logical indicating the state of the system
C                         at time T2.
C
C                UDREFN may use or ignore the S1 and S2 values.
C
C                The output is:
C
C                   T     a time to check for a state transition
C                         between T1 and T2.
C
C                If a simple bisection method is desired, the routine
C                GFREFN may be used. This is the default option.
C
C     UDQDEC     the routine that determines if the geometric quantity
C                is decreasing.
C
C                The calling sequence:
C
C                   CALL UDQDEC ( ET, ISDECR )
C
C                where:
C
C                   ET       a double precision value representing
C                            ephemeris time, expressed as seconds past
C                            J2000 TDB, at which to determine the time
C                            derivative of the geometric quantity.
C
C                   ISDECR   a logical return indicating whether
C                            or not the geometric quantity
C                            is decreasing. ISDECR returns true if the
C                            time derivative of the geometric quantity
C                            at ET is negative.
C
C     UDCOND     the routine that determines if the geometric quantity
C                satisfies some constraint condition at epoch ET.
C
C                The calling sequence:
C
C                   CALL UDCOND ( ET, IN_CON )
C
C                where:
C
C                   ET       a double precision value representing
C                            ephemeris time, expressed as seconds past
C                            J2000 TDB, at which to evaluate the
C                            geometric quantity.
C
C                   IN_CON   a logical value indicating whether or
C                            not the geometric quantity satisfies the
C                            constraint at ET (TRUE) or not (FALSE).
C
C     UDFUNC     the routine that returns the value of the geometric
C                quantity at the time of interest. The calling sequence
C                for UDFUNC is:
C
C                   CALL UDFUNC ( TIME, VALUE )
C
C                where:
C
C                   TIME    a double precision value representing
C                           ephemeris time, expressed as seconds past
C                           J2000 TDB, at which  to determine
C                           the value of the geometric quantity.
C
C                   VALUE   is the value of the geometric quantity at
C                           time TIME.
C
C     UDQREF     the routine that resets the current value of REFVAL.
C                The calling sequence for UDQREF is:
C
C                   CALL UDQREF ( REFER2 )
C
C                where REFER2 is a new value of REFVAL.
C
C     RELATE     is a comparison operator, indicating the numeric
C                constraint of interest. Values are:
C
C                '>'   value of geometric quantity greater than some
C                      reference (REFVAL).
C
C                '='   value of geometric quantity equal to some
C                      reference (REFVAL).
C
C                '<'   value of geometric quantity less than some
C                      reference (REFVAL).
C
C                ABSMAX-the geometric quantity is at an absolute
C                maximum.
C
C                ABSMIN-the geometric quantity is at an absolute
C                minimum.
C
C                LOCMAX-the geometric quantity is at an local maximum.
C
C                LOCMIN-the geometric quantity is at an local minimum.
C
C     REFVAL     Reference value for geometric quantity (in
C                radians, radians/sec, km, or km/sec as appropriate).
C
C     TOL        is a tolerance value used to determine convergence of
C                root-finding operations.  TOL is measured in seconds
C                and is greater than zero.
C
C     ADJUST     The amount by which the numerical quantity is
C                allowed to vary from an absolute extremum. If ADJUST
C                is non-zero, the resulting schedule contains
C                intervals when the geometric quantity has
C                values either between ABSMIN and ABSMIN + ADJUST
C                or between ABSMAX and ABSMAX - ADJUST. ADJUST must
C                not be negative.
C
C     CNFINE     is a SPICE window that confines the bounds of the
C                search. Note that like all windows (see windows.req)
C                CNFINE can contain multiple time intervals. See the
C                Examples section for information on how to create this
C                window.
C
C     MW         is the cell size of the windows in the workspace array
C                WORK.
C
C     NW         is the number of windows in the workspace array WORK.
C                NW must be at least as large as the parameter NWREQ.
C
C     WORK       is an array used to store workspace windows. This
C                array has dimensions WORK (-5 : MW, NW).
C
C     RPT        is a logical variable which controls whether the
C                progress reporter is on or off. The progress reporter
C                writes to the user's terminal.
C
C     UDREPI     the routine that initializes a progress report.
C                When progress reporting is enabled, UDREPI
C                is called at the start of a search.  The calling
C                sequence of UDREPI is:
C
C                   UDREPI ( CNFINE, RPTPRE, RPTSUF )
C
C                   DOUBLE PRECISION    CNFINE ( LBCELL : * )
C                   CHARACTER*(*)       RPTPRE
C                   CHARACTER*(*)       RPTSUF
C
C                where
C
C                   CNFINE
C
C                is the confinement window passed into ZZGFRELX, and
C
C                   RPTPRE
C                   RPTSUF
C
C                are prefix and suffix strings used in the progress
C                report:  these strings are intended to bracket a
C                representation of the fraction of work done.
C
C                If the user has no progress reporting initialization
C                routine, the SPICELIB routine GFRPIN may be used. This
C                is the default option.
C
C     UDREPU     the routine that updates the progress report for a
C                search.  The calling sequence of UDREPU is:
C
C                   UDREPU (IVBEG, IVEND, ET )
C
C                   DOUBLE PRECISION      ET
C                   DOUBLE PRECISION      IVBEG
C                   DOUBLE PRECISION      IVEND
C
C                where ET is an epoch belonging to the confinement
C                window, IVBEG and IVEND are the start and stop times,
C                respectively of the current confinement window
C                interval.  The ratio of the measure of the portion
C                of CNFINE that precedes ET to the measure of CNFINE
C                would be a logical candidate for the search's
C                completion percentage; however the method of
C                measurement is up to the user.
C
C                If the user has no progress reporting update routine,
C                the SPICELIB routine GFRPUD may be used. This is the
C                default option.
C
C     UDREPF     the routine that finalizes a progress report. UDREPF
C                has no arguments.
C
C                If the user has no progress reporting finalizing
C                routine, the SPICELIB routine GFRPEN may be used. This
C                is the default option.
C
C     RPTPRE     is an array of strings containing the prefixes of
C                the output messages reported by the progress reporter.
C                The Ith element of RPTPRE is the prefix for the
C                message corresponding to the Ith traversal of the
C                confinement window executed by this routine; such
C                traversals are called "passes." The number of passes
C                executed depends on the relational operator RELATE.
C                Searches for local extrema and unadjusted absolute
C                extrema require one pass; searches for adjusted
C                absolute extrema, equalities, and inequalities require
C                two passes.
C
C                An example of the contents of RPTPRE for a distance
C                equality search:
C
C                   RPTPRE(1) = 'Distance pass 1 of 2'
C                   RPTPRE(2) = 'Distance pass 2 of 2'
C
C     RPTSUF     is an array of strings containing the suffixes of
C                the output messages reported by the progress reporter.
C                The Ith element of RPTSUF is the suffix for the
C                message corresponding to the Ith pass.
C
C                An example of the contents of RPTSUF for a distance
C                equality search:
C
C                   RPTSUF(1) = 'done.'
C                   RPTSUF(2) = 'done.'
C
C                For this search, the complete progress report message
C                for the Ith pass has the form
C
C                   'Distance pass I of 2 xxx.xx% done.'
C
C     BAIL       is a logical indicating whether or not interrupt
C                signaling is enabled.
C
C     UDBAIL     the routine that checks to see whether an interrupt
C                signal has been issued from, e.g. the keyboard. If
C                this capability is not to be used, a dummy function,
C                ZZGFBAIL must be supplied.
C
C     RESULT     is an initialized SPICE window. RESULT is large
C                enough to hold all of the intervals, within the
C                confinement window, on which the specified condition
C                is met.
C
C$ Detailed_Output
C
C     RESULT     is a SPICE window containing the time intervals within
C                the confinement window, over which the specified
C                condition is met.
C
C                RESULT is emptied before new values are assigned to
C                it.
C
C$ Parameters
C
C     LBCELL     is the SPICELIB cell lower bound.
C
C     NWREQ      is the required number of workspace windows; the
C                input argument NW must not be less than NWREQ.
C
C$ Exceptions
C
C     1)  A negative value for ADJUST causes the routine to signal
C         the error SPICE(VALUEOUTOFRANGE). A non-zero value for ADJUST
C         when RELATE has any value other than "ABSMIN" or "ABSMAX",
C         causes the routine to signal the error SPICE(INVALIDVALUE).
C
C     2)  If an improper comparison operator is specified, the error
C         SPICE(NOTRECOGNIZED) is signaled.
C
C     3)  If TOL is not greater than zero, the error
C         SPICE(VALUEOUTOFRANGE) will be signaled by routines called
C         from this routine.
C
C     4)  If the number of workspace windows is less than NWREQ, the
C         error SPICE(TOOFEWWINDOWS) is signaled.
C
C     5)  If the window size MW is less than 2, the error
C         SPICE(INVALIDDIMENSION) will be signaled.
C
C     6)  If the output SPICE window RESULT has insufficient capacity
C         to contain the number of intervals on which the specified
C         visibility condition is met, the error will be diagnosed
C         by a routine in the call tree of this routine. If the result
C         window has size less than 2, the error SPICE(WINDOWTOOSMALL)
C         will be signaled by this routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine determines time intervals when the value of some
C     geometric quantity related to one or more objects and an observer
C     satisfies a user specified constraint. It puts these times in a
C     result window called RESULT. It does this by first finding
C     schedules (windows) when the quantity of interest is either
C     monotonically increasing or decreasing. These schedules are then
C     manipulated to give the final result. Note that the determination
C     of "=" involves finding intervals where the quantity is "less
C     than" to a tolerance of TOL. This means that the end points of
C     these intervals are within TOL of being equal to the value.
C
C$ Examples
C
C     See GFEVNT.
C
C$ Restrictions
C
C     The kernel files to be used by ZZGFREL must be loaded (normally
C     via the SPICELIB routine FURNSH) before ZZGFREL is called.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     L.S. Elson     (JPL)
C     W.L. Taber     (JPL)
C     I.M. Underwood (JPL)
C     E.D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1  21-DEC-2009 (EDW)
C
C        Edit to Abstract to document sister routine ZZGFRELX.
C
C-    SPICELIB Version 1.0.0  21-FEB-2009 (NJB) (LSE) (WLT) (IMU) (EDW)
C
C-&

C$ Index_Entries
C
C     determine when a scalar quantity satisfies a condition
C
C-&

C
C     SPICELIB functions
C
      INTEGER               CARDD
      INTEGER               ISRCHC
      INTEGER               SIZED
      INTEGER               WNCARD

      LOGICAL               FAILED
      LOGICAL               RETURN

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

      INTEGER               RIGHT
      PARAMETER           ( RIGHT  = 2 )

      INTEGER               MAXCLN
      PARAMETER           ( MAXCLN = 80 )

C
C     Workspace window indices:
C
      INTEGER               CONFIN
      PARAMETER           ( CONFIN = 3 )

      INTEGER               COPY
      PARAMETER           ( COPY   = 4 )

      INTEGER               DECRES
      PARAMETER           ( DECRES = 2 )

      INTEGER               INCRES
      PARAMETER           ( INCRES = 1 )

      INTEGER               TEMPW
      PARAMETER           ( TEMPW  = 5 )

C
C     Number of supported comparison operators.
C
      INTEGER               NC
      PARAMETER           ( NC     = 7 )

C     One-letter alias for LBCELL to make references to the workspace
C     array tolerable:
C
      INTEGER               B
      PARAMETER           ( B      = LBCELL )

C
C     Context string length:
C
      INTEGER               CTXLEN
      PARAMETER           ( CTXLEN = 500 )

C
C     Local variables
C

      CHARACTER*(MAXCLN)    CNAMES ( NC )
      CHARACTER*(CTXLEN)    CONTXT
      CHARACTER*(MAXCLN)    LOCREL

      DOUBLE PRECISION      ADDL
      DOUBLE PRECISION      ADDR
      DOUBLE PRECISION      ENDPT  (  2 )
      DOUBLE PRECISION      EXTREM
      DOUBLE PRECISION      FINISH
      DOUBLE PRECISION      REFER2
      DOUBLE PRECISION      START
      DOUBLE PRECISION      STEP
      DOUBLE PRECISION      VALUE

      INTEGER               CASE
      INTEGER               COUNT
      INTEGER               I
      INTEGER               MAXAT
      INTEGER               MINAT
      INTEGER               NAME    (  2 )
      INTEGER               PASS
      INTEGER               QCNUM
      INTEGER               WANT
      INTEGER               WINSIZ

      LOGICAL               CSTEP
      LOGICAL               NEED

C
C     Saved variables
C
      SAVE                  CNAMES

C
C     Below we initialize the list of comparison operator names.
C
      DATA                  CNAMES / '<',
     .                               '=',
     .                               '>',
     .                               'LOCMIN',
     .                               'ABSMIN',
     .                               'LOCMAX',
     .                               'ABSMAX'  /

C
C     Set constant step parameter to .FALSE..
C
      DATA                  CSTEP / .FALSE. /

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

      CALL CHKIN  ( 'ZZGFREL' )

C
C     Make sure we have enough workspace windows.
C
      IF ( NW .LT. NWREQ ) THEN

         CALL SETMSG ( 'The number of workspace windows (#) is less '
     .   //            'than the minimum #.'                         )
         CALL ERRINT ( '#',  NW                                      )
         CALL ERRINT ( '#',  NWREQ                                   )
         CALL SIGERR ( 'SPICE(TOOFEWWINDOWS)'                        )
         CALL CHKOUT ( 'ZZGFREL'                                     )
         RETURN

      END IF

C
C     Make sure the workspace windows can contain at least one interval.
C
      IF ( MW .LT. 2 ) THEN

         CALL SETMSG ( 'Workspace window size was #; size must be '
     .   //            'at least 2.'                               )
         CALL ERRINT ( '#',  MW                                    )
         CALL SIGERR ( 'SPICE(INVALIDDIMENSION)'                   )
         CALL CHKOUT ( 'ZZGFREL'                                   )
         RETURN

      END IF

C
C     Check the result window size.
C
      IF ( SIZED(RESULT) .LT. 2 ) THEN

         CALL SETMSG ( 'Result window size was #; size must be '
     .   //            'at least 2.'                             )
         CALL ERRINT ( '#',  SIZED(RESULT)                       )
         CALL SIGERR ( 'SPICE(INVALIDDIMENSION)'                 )
         CALL CHKOUT ( 'ZZGFREL'                                 )
         RETURN

      END IF

C
C     Make sure the requested comparison is one we recognize.
C
      CALL LJUST ( RELATE, LOCREL )
      CALL UCASE ( LOCREL, LOCREL )

      QCNUM = ISRCHC ( LOCREL, NC, CNAMES )

      IF ( QCNUM .EQ. 0 ) THEN

        CALL SETMSG ('The comparison operator, # is not '            //
     .               'recognized.  Supported quantities are: '       //
     .               '<, '                                           //
     .               '=, '                                           //
     .               '>, '                                           //
     .               'LOCMIN, '                                      //
     .               'ABSMIN, '                                      //
     .               'LOCMAX, '                                      //
     .               'ABSMAX.'                                        )
         CALL ERRCH  ('#', RELATE                                     )
         CALL SIGERR ('SPICE(NOTRECOGNIZED)'                          )
         CALL CHKOUT ('ZZGFREL'                                       )
         RETURN

      END IF

C
C     Confirm ADJUST is non-negative.
C
      IF ( ADJUST .LT. 0.D0 ) THEN

         CALL SETMSG ( 'ADJUST was #; must be non-negative.' )
         CALL ERRDP  ( '#',  ADJUST                          )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'              )
         CALL CHKOUT ( 'ZZGFREL'                             )
         RETURN

      END IF

C
C    Confirm ADJUST equals zero unless LOCREL (RELATE) has value
C    "ABSMAX" or "ABSMIN."
C
      IF(  (LOCREL .NE. 'ABSMIN')  .AND. (LOCREL .NE. 'ABSMAX' ) ) THEN

         IF ( ADJUST .NE. 0.D0 ) THEN

            CALL SETMSG ( 'ADJUST should have value zero for all '  //
     .                    'comparison operators except ABSMAX and ' //
     .                    'ABSMIN' )
            CALL SIGERR ( 'SPICE(INVALIDVALUE)'                     )
            CALL CHKOUT ( 'ZZGFREL'                                 )
            RETURN

         END IF

      END IF

C
C     If the confinement window is empty, the result window must
C     be empty as well.  In this case, there's not much to do.
C
      IF ( CARDD(CNFINE) .EQ. 0 ) THEN

         CALL SCARDD ( 0, RESULT )
         CALL CHKOUT ('ZZGFREL' )
         RETURN

      END IF

C
C     We need to set up several working windows, one each for
C     increasing and decreasing schedules, one for the confining
C     schedule and one for copying.
C
      CALL SSIZED ( MW, WORK(B,DECRES) )
      CALL SSIZED ( MW, WORK(B,INCRES) )
      CALL SSIZED ( MW, WORK(B,CONFIN) )
      CALL SSIZED ( MW, WORK(B,COPY  ) )
      CALL SSIZED ( MW, WORK(B,TEMPW ) )

      NAME(1) = DECRES
      NAME(2) = INCRES

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

C
C     For equality constraints, we work with a somewhat expanded
C     version of the confinement window so we can find equality
C     solutions that lie on the boundary of the original confinement
C     window. The expansion amount is ADDWIN. For other cases the
C     expansion amount is set to zero.
C
      IF ( RELATE .EQ.  '=' ) THEN

         ADDL = ADDWIN
         ADDR = ADDWIN
      ELSE
         ADDL = 0.0D0
         ADDR = 0.0D0
      END IF

      CALL COPYD  ( CNFINE,     WORK(B,CONFIN) )
      CALL WNEXPD ( ADDL, ADDR, WORK(B,CONFIN) )

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

C
C     Make a local copy of the reference value.
C
      REFER2 = REFVAL

C
C     Set the pass number for progress reporting.
C
      PASS = 1

C
C     Initialize the work in progress reporter.
C
      IF ( RPT ) THEN
         CALL UDREPI ( WORK(B,CONFIN), RPTPRE(PASS), RPTSUF(PASS) )
      END IF

C
C     Look up the size of the confinement schedule...
C
      COUNT = WNCARD ( WORK(B,CONFIN) )

C
C     Start the window that contains intervals when the quantity of
C     interest is decreasing. The result will contain all intervals in
C     (expanded) CNFINE when the selected geometric quantity function
C     is decreasing, since this is how ZZGFSOLV is configured.
C
      DO I = 1, COUNT
C
C        Locate the bounds for the I'th interval of the confinement
C        schedule. Results are accumulated in the WORK array.
C
         CALL WNFETD ( WORK(B,CONFIN), I, START, FINISH  )

         CALL ZZGFSOLV ( UDQDEC,  UDSTEP, UDREFN,  BAIL,
     .                   UDBAIL,  CSTEP,  STEP,    START,
     .                   FINISH,  TOL,    RPT,     UDREPU,
     .                   WORK(B,DECRES) )

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

         IF ( BAIL ) THEN

            IF ( UDBAIL () ) THEN

               IF ( RPT ) THEN
                  CALL UDREPF
               END IF

               CALL CHKOUT ( 'ZZGFREL' )
               RETURN

            END IF

         END IF

      END DO

      IF ( RPT ) THEN
         CALL UDREPF
      END IF

C
C     Let's think about what we have now. We have the intervals in the
C     confinement window when a value of some kind is decreasing.
C
C     The left endpoints are points at which the quantity begins
C     decreasing, thus they are times when the quantity is at a local
C     maximum (at least in the interior of the confinement window).
C
C     The right endpoints are where the quantity stops decreasing. Thus
C     those endpoints in the interior of the confinement window are
C     local minima of the quantity.
C
C     The complement relative to the confinement window is the set of
C     intervals within the confinement window for which the quantity is
C     increasing. At the left endpoints of the complement the
C     function is increasing. Thus the interior left endpoints are
C     local minima within the confinement window. The interior right
C     endpoints are local maxima within the confinement window.
C
C     Moreover, to within our ability to detect local extrema, there
C     are no local extrema within any of the intervals. Thus, the
C     function may be regarded as monotone within each of
C     the intervals of these windows. Thus for any desired value of the
C     quantity, there is at most one time within each of the intervals
C     that the desired value is achieved.
C
      IF ( LOCREL .EQ. 'LOCMIN' ) THEN
C
C        We are interested in only interior minima of the quantity.
C        These occur at right endpoints of the intervals in TEMPW
C        that are interior points of CNFINE. First extract the right
C        endpoints. Then find those that are contained in the initial
C        confinement schedule, excluding endpoints.
C
         CALL WNEXTD ( 'R', WORK(B,DECRES) )

         CALL ZZGFWSTS ( WORK(B,DECRES), CNFINE, '()', RESULT )

         CALL CHKOUT (  'ZZGFREL' )
         RETURN

      ELSE IF ( LOCREL .EQ. 'LOCMAX' ) THEN
C
C        We are interested in only interior maxima of the quantity.
C        These occur at right endpoints of the intervals in TEMPW
C        that are interior points of CNFINE.
C
         CALL WNEXTD ( 'L', WORK(B,DECRES) )

         CALL ZZGFWSTS ( WORK(B,DECRES), CNFINE,  '()',  RESULT )

         CALL CHKOUT (  'ZZGFREL' )
         RETURN

      END IF

C
C     We will need the intervals when the quantity of interest is
C     increasing in value.
C
      IF ( ( LOCREL .EQ. 'ABSMIN') .OR. ( LOCREL .EQ. 'ABSMAX') ) THEN
C
C        We need an absolute max or min over the schedule CNFINE.
C        But we have decreasing values in WORK(B,DECRES).
C        Make a copy of WORK(B,DECRES) then compute the schedules
C        of decreasing or increasing quantity over the schedule CNFINE.
C
         CALL COPYD  ( WORK(B,DECRES), WORK(B,COPY) )

         CALL WNINTD ( CNFINE,         WORK(B,DECRES), WORK(B,TEMPW ) )
         CALL COPYD  ( WORK(B,TEMPW),                  WORK(B,DECRES) )

         CALL WNDIFD ( CNFINE,         WORK(B,DECRES), WORK(B,TEMPW ) )
         CALL COPYD  ( WORK(B,TEMPW),                  WORK(B,INCRES) )

C
C        Here's what we plan to do, we want to look over two schedules
C        DECREASING and INCREASING to search for the absolute max or
C        min.  We start with DECREASING.  In this schedule the max is
C        always at the left endpoint,  The min is at the right
C        endpoint.  In the INCREASING schedule the min is at the LEFT
C        endpoint of an interval, the max is at the RIGHT endpoint of
C        an interval
C
         MINAT = RIGHT
         MAXAT = LEFT

C
C        As yet we still need to compute our first extremum.
C
         NEED  = .TRUE.

C
C        The extrema search is logically the same for both
C        maximum and minimum. We just need to keep track of
C        our extremum and when we find a more extreme value
C        replace it. DECREASING is first.
C
         DO CASE = 1, 2

            IF ( LOCREL .EQ. 'ABSMIN' ) THEN

               WANT  = MINAT

            ELSE IF ( LOCREL .EQ. 'ABSMAX' ) THEN

               WANT  = MAXAT

            END IF

            WINSIZ = WNCARD (  WORK( B, NAME(CASE) )  )

            DO I = 1, WINSIZ

               CALL WNFETD ( WORK( B,  NAME(CASE) ), I,
     .                       ENDPT(1), ENDPT(2)  )

               CALL UDFUNC ( ENDPT(WANT), VALUE )

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

C
C              Initialize the extreme value. This step will
C              be executed on the first pass through the
C              DECREASING interval.
C
               IF ( NEED ) THEN

                  NEED   = .FALSE.
                  EXTREM = VALUE

               END IF

C
C              Check to see if current VALUE is more extreme than
C              EXTREM.
C
               IF ( LOCREL .EQ. 'ABSMIN' ) THEN

                  IF (       ( ADJUST .EQ. 0.0D0  )
     .                 .AND. ( VALUE  .LE. EXTREM )  ) THEN
C
C                    Let's save the epoch in case it's that of the
C                    absolute min. Add this endpoint as a singleton
C                    interval to the RESULT window.
C
                     CALL SCARDD ( 0, RESULT )

                     CONTXT = 'Saving current candidate epoch at '
     .               //       'which an absolute minimum may occur.'

                     CALL ZZWNINSD ( ENDPT(WANT), ENDPT(WANT),
     .                               CONTXT,      RESULT      )

                  END IF

                  EXTREM = MIN ( EXTREM, VALUE )

               ELSE

                  IF (       ( ADJUST .EQ. 0.0D0  )
     .                 .AND. ( VALUE  .GE. EXTREM )  ) THEN
C
C                    Let's save the epoch in case it's that of the
C                    absolute max. Add this endpoint as a singleton
C                    interval to the RESULT window.
C
                     CALL SCARDD ( 0, RESULT )

                     CONTXT = 'Saving current candidate epoch at '
     .               //       'which an absolute maximum may occur.'

                     CALL ZZWNINSD ( ENDPT(WANT), ENDPT(WANT),
     .                               CONTXT,      RESULT      )

                  END IF

                  EXTREM = MAX ( EXTREM, VALUE )

               END IF

            END DO

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

C
C           When we go to the next schedule, the min and max are at
C           opposite ends of the intervals.
C
            CALL SWAPI ( MINAT, MAXAT )

         END DO

C
C        If the adjustment is zero, we're done.
C
         IF ( ADJUST .EQ. 0.0D0 ) THEN

            CALL CHKOUT (  'ZZGFREL' )
            RETURN

         END IF

C
C        We have a non-zero adjustment. we have the extreme value. Now
C        we need to find the epochs when the extreme value is achieved,
C        allowing for adjustment.
C
         IF ( LOCREL  .EQ. 'ABSMIN' ) THEN

            REFER2 = EXTREM + ADJUST

         ELSE
C
C           The only other possible value of LOCREL within this block
C           is 'ABSMAX'.
C
            REFER2 = EXTREM - ADJUST

         END IF
C
C        If we reach this point, we need to re-establish the
C        original expanded coverage of 'DECREASING' and 'INCREASING'.
C
         CALL COPYD ( WORK(B,COPY), WORK(B,DECRES) )

      END IF

      CALL WNDIFD ( WORK(B,CONFIN), WORK(B,DECRES), WORK(B,INCRES) )

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

C
C     We have some kind of greater than, less than, or equal to
C     relation to solve for. Note that ABSMAX and ABSMIN are for case
C     where there is a non-zero adjustment. Reset the reference value,
C     which may have been changed in the ABSOLUTE MAX or MIN blocks
C     above.
C
      CALL UDQREF ( REFER2 )

C
C     If progress reporting is enabled, initialize the progress
C     reporter for a second pass over the confinement window.
C
      IF ( RPT ) THEN
C
C        Note that the window passed to UDREPI need not contain the
C        same intervals as those passed to UDREPU; the window passed to
C        UPREPI need only have the correct measure. From UDREPI's
C        perspective, the sole purpose of this window is to convey to
C        the progress reporting system the sum of the measures of the
C        increasing and decreasing windows.
C
         PASS = 2

         CALL UDREPI ( WORK(B,CONFIN), RPTPRE(PASS), RPTSUF(PASS) )

      END IF

C
C     Find those intervals when the geometric quantity is less than
C     REFER2.
C
      CALL SCARDD ( 0, RESULT )

      DO CASE = 1, 2

         WINSIZ = WNCARD (  WORK(B, NAME(CASE))  )

C
C        Search each interval of the window identified by NAME(CASE) for
C        times when the quantity is less than the reference value.
C
         DO I = 1, WINSIZ

            CALL WNFETD ( WORK( B, NAME(CASE)), I, START, FINISH  )
C
C           For each interval, accumulate the result in RESULT.
C
C           Note we know that the behavior of the quantity is monotonic
C           within each window, so the step size can be large. In fact,
C           we use the interval length as the step size.
C
            STEP = FINISH - START

            CALL ZZGFSOLV ( UDCOND, UDSTEP,  UDREFN,  BAIL,
     .                      UDBAIL, .TRUE.,  STEP,    START,
     .                      FINISH, TOL,     RPT,     UDREPU,
     .                      RESULT                           )

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

            IF ( BAIL ) THEN
               IF ( UDBAIL () ) THEN
                  CALL CHKOUT ( 'ZZGFREL' )
                  RETURN
               END IF
            END IF

         END DO

      END DO

      IF ( RPT ) THEN
C
C        Finish the progress report for the second pass.
C
         CALL UDREPF

      END IF

C
C     RESULT is the window, within the expanded confinement window,
C     over which the function of interest is less than the reference
C     value. We can use this window to get whatever was requested.
C
      IF ( ( LOCREL .EQ. '<' ) .OR. ( LOCREL .EQ. 'ABSMIN' ) ) THEN
C
C        We simply need to restrict our result to the original
C        confinement schedule. Note that the ABSMIN search with
C        non-zero adjustment is now a search for values less than the
C        adjusted absolute minimum. Same for ABSMAX below.
C
         CALL WNINTD ( CNFINE,         RESULT,  WORK(B,TEMPW) )
         CALL COPYD  ( WORK(B,TEMPW),           RESULT        )

      ELSE IF ( ( LOCREL .EQ. '>' ) .OR. ( LOCREL .EQ. 'ABSMAX' ) ) THEN
C
C        Subtract from the confinement window the window where the
C        quantity is less than the reference value: the remainder is
C        the portion of the confinement window on which the quantity is
C        greater than or equal to the reference value.
C
         CALL WNDIFD ( CNFINE,         RESULT,  WORK(B,TEMPW) )
         CALL COPYD  ( WORK(B,TEMPW),           RESULT        )

      ELSE
C
C        This is the branch for the relational operator '='.
C
C        Create a window of singleton intervals from the endpoints
C        of RESULT.
C
         CALL SCARDD ( 0, WORK(B,TEMPW) )

         DO I = 1, CARDD(RESULT)

            CONTXT = 'Inserting endpoints of result window into '
     .      //       'workspace window WORK(B,TEMPW). These points '
     .      //       'are candidate epochs that may satisfy an '
     .      //       'equality constraint.'

            CALL ZZWNINSD ( RESULT(I), RESULT(I),
     .                      CONTXT,    WORK(B,TEMPW) )

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

         END DO

C
C        The window WORK(B,TEMPW) contains singleton intervals where
C        either the equality constraint is met, or where a boundary
C        point of the expanded confinement window is located. We're not
C        interested in the boundary points; these are likely not
C        solution points and in any case are outside the original
C        confinement window.
C
C        Keep only the endpoints of RESULT that are contained in the
C        original confinement window CNFINE; these are by construction
C        interior points of the expanded confinement window.
C
         CALL WNINTD ( CNFINE,  WORK(B,TEMPW),  RESULT )

      END IF

      CALL CHKOUT ( 'ZZGFREL' )
      RETURN
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYFILL
C...Fills entry in histogram.

      SUBROUTINE PYFILL(ID,X,W)

C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      include 'inc/pybins'

C...Find initial address in memory. Increase number of entries.
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
     &'(PYFILL:) not allowed histogram number')
      IS=INDX(ID)
      IF(IS.EQ.0) CALL PYERRM(28,
     &'(PYFILL:) filling unbooked histogram')
      BIN(IS+5)=BIN(IS+5)+1D0

C...Find bin in x, including under/overflow, and fill.
      IF(X.LT.BIN(IS+2)) THEN
        BIN(IS+6)=BIN(IS+6)+W
      ELSEIF(X.GE.BIN(IS+3)) THEN
        BIN(IS+8)=BIN(IS+8)+W
      ELSE
        BIN(IS+7)=BIN(IS+7)+W
        IX=(X-BIN(IS+2))/BIN(IS+4)
        IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
        BIN(IS+9+IX)=BIN(IS+9+IX)+W
      ENDIF

      RETURN
      END


c
c     aerosol profile data, nicked from modtran (see relevant
c     references from AFGL) and cleaned up a little.
c
c   zaerd              The altitude at which the densities are given
c
c 0-2km
c
c   hzviz(lc,iviz)     Haze visibility profiles 0-2km,
c                      iviz = 1 visibility 50km
c                      iviz = 2 visibility 23km
c                      iviz = 3 visibility 10km
c                      iviz = 4 visibility 5km
c                      iviz = 5 visibility 2km
c >2-10km
c                      fawi50=fall/winter   50km vis
c                      fawi23=fall/winter    23km vis
c                      spsu50=spring/summer  50km vis
c                      spsu23=spring/summer  23km vis
c >10-30km
c                      bastfw=background stratospheric   fall/winter
c                      vumofw=moderate volcanic          fall/winter
c                      hivufw=high volcanic              fall/winter
c                      exvufw=extreme volcanic           fall/winter
c                      bastss,vumoss,hivuss,exvuss=      spring/summer
c >30-100km
c                      upnatm=normal upper atmospheric
c                      vutono=transition from volcanic to normal
c                      vutoex=transition from volcanic to extreme
c                      exupat=extreme upper atmospheric
c
c
      REAL zaerd(34),
     $     hzviz(35,5), fawi50(34), fawi23(34),
     $     spsu50(34), spsu23(34), bastfw(34), vumofw(34),
     $     hivufw(34),exvufw(34),bastss(34), vumoss(34),
     $     hivuss(34),exvuss(34),upnatm(34),vutono(34),
     $     vutoex(34),exupat(34)
c
      data zaerd/
     $    0.,    1.,    2.,    3.,    4.,
     $     5.,    6.,    7.,    8.,
     $    9.,   10.,   11.,   12.,   13.,
     $     14.,   15.,   16.,   17.,
     $   18.,   19.,   20.,   21.,   22.,
     $     23.,   24.,   25.,   30.,
     $   35.,   40.,   45.,   50.,   70.,
     $     100.,99999./
c
       data hzviz(1,1),hzviz(1,2),hzviz(1,3),hzviz(1,4),hzviz(1,5)/
     $      6.62e-02,  1.58e-01,  3.79e-01,  7.70e-01,  1.94e+00/
       data hzviz(2,1),hzviz(2,2),hzviz(2,3),hzviz(2,4),hzviz(2,5)/
     $      4.15e-02,  9.91e-02,  3.79e-01,  7.70e-01,  1.94e+00/
       data hzviz(3,1),hzviz(3,2),hzviz(3,3),hzviz(3,4),hzviz(3,5)/
     $      2.60e-02,  6.21e-02,  6.21e-02,  6.21e-02,  6.21e-02/
c
      data fawi50  /3*0.,
     $ 1.14e-02, 6.43e-03, 4.85e-03, 3.54e-03, 2.31e-03, 1.41e-03,
     $ 9.80e-04,7.87e-04,23*0./
c
      data fawi23              /3*0.,
     1 2.72e-02, 1.20e-02, 4.85e-03, 3.54e-03, 2.31e-03, 1.41e-03,
     2 9.80e-04,7.87e-04,23*0./
c
      data  spsu50              / 3*0.,
     1 1.46e-02, 1.02e-02, 9.31e-03, 7.71e-03, 6.23e-03, 3.37e-03,
     2 1.82e-03  ,1.14e-03,23*0./
c
      data  spsu23              / 3*0.,
     1 3.46e-02, 1.85e-02, 9.31e-03, 7.71e-03, 6.23e-03, 3.37e-03,
     2 1.82e-03  ,1.14e-03,23*0./
c
      data bastfw       /11*0.,
     1           7.14e-04, 6.64e-04, 6.23e-04, 6.45e-04, 6.43e-04,
     2 6.41e-04, 6.00e-04, 5.62e-04, 4.91e-04, 4.23e-04, 3.52e-04,
     3 2.95e-04, 2.42e-04, 1.90e-04, 1.50e-04, 3.32e-05 ,7*0./
c
      data    vumofw       /11*0.,
     1           1.79e-03, 2.21e-03, 2.75e-03, 2.89e-03, 2.92e-03,
     2 2.73e-03, 2.46e-03, 2.10e-03, 1.71e-03, 1.35e-03, 1.09e-03,
     3 8.60e-04, 6.60e-04, 5.15e-04, 4.09e-04, 7.60e-05 ,7*0./
c
      data    hivufw       /11*0.,
     1           2.31e-03, 3.25e-03, 4.52e-03, 6.40e-03, 7.81e-03,
     2 9.42e-03, 1.07e-02, 1.10e-02, 8.60e-03, 5.10e-03, 2.70e-03,
     3 1.46e-03, 8.90e-04, 5.80e-04, 4.09e-04, 7.60e-05 ,7*0./
c
      data    exvufw       /11*0.,
     1           2.31e-03, 3.25e-03, 4.52e-03, 6.40e-03, 1.01e-02,
     2 2.35e-02, 6.10e-02, 1.00e-01, 4.00e-02, 9.15e-03, 3.13e-03,
     3 1.46e-03, 8.90e-04, 5.80e-04, 4.09e-04, 7.60e-05 ,7*0./
c
      data    bastss       /11*0.,
     1           7.99e-04, 6.41e-04, 5.17e-04, 4.42e-04, 3.95e-04,
     2 3.82e-04, 4.25e-04, 5.20e-04, 5.81e-04, 5.89e-04, 5.02e-04,
     3 4.20e-04, 3.00e-04, 1.98e-04, 1.31e-04, 3.32e-05 ,7*0./
c
      data    vumoss       /11*0.,
     1           2.12e-03, 2.45e-03, 2.80e-03, 2.89e-03, 2.92e-03,
     2 2.73e-03, 2.46e-03, 2.10e-03, 1.71e-03, 1.35e-03, 1.09e-03,
     3 8.60e-04, 6.60e-04, 5.15e-04, 4.09e-04, 7.60e-05 ,7*0./
c
      data    hivuss       /11*0.,
     1           2.12e-03, 2.45e-03, 2.80e-03, 3.60e-03, 5.23e-03,
     2 8.11e-03, 1.20e-02, 1.52e-02, 1.53e-02, 1.17e-02, 7.09e-03,
     3 4.50e-03, 2.40e-03, 1.28e-03, 7.76e-04, 7.60e-05 ,7*0./
c
      data    exvuss       /11*0.,
     1           2.12e-03, 2.45e-03, 2.80e-03, 3.60e-03, 5.23e-03,
     2 8.11e-03, 1.27e-02, 2.32e-02, 4.85e-02, 1.00e-01, 5.50e-02,
     3 6.10e-03, 2.40e-03, 1.28e-03, 7.76e-04, 7.60e-05 ,7*0./
c
      data upnatm       /26*0.,
     1 3.32e-05, 1.64e-05, 7.99e-06, 4.01e-06, 2.10e-06, 1.60e-07,
     2 9.31e-10, 0.      /
c
      data vutono       /26*0.,
     1 7.60e-05, 2.45e-05, 7.99e-06, 4.01e-06, 2.10e-06, 1.60e-07,
     2 9.31e-10, 0.      /
c
      data vutoex       /26*0.,
     1 7.60e-05, 7.20e-05, 6.95e-05, 6.60e-05, 5.04e-05, 1.03e-05,
     2 4.50e-07, 0.      /
c
      data exupat       /26*0.,
     1 3.32e-05, 4.25e-05, 5.59e-05, 6.60e-05, 5.04e-05, 1.03e-05,
     2 4.50e-07, 0.      /
c