      MODULE TRACER_SOURCES
      USE TRACER_COM

      IMPLICIT NONE
      SAVE

!@param nlightning index number of 3D source for NOx from lightning
!@param naircraft index number of 3D source for NOx from aircraft
!@param nStratwrite idx number of 3D tracer source from strat overwrite
!@param nChemistry index number of 3D tracer source from chemistry
!@param Laircr the number of layers of aircraft data read from file
!@param Lsulf the number of layers of sulfate SA data read from file
!@param correct_CO_ind correction factor Lee put in for industrial CO
      INTEGER, PARAMETER :: nChemistry  = 1,
     &                      nStratwrite = 2,
     &                      nLightning  = 3,
     &                      nAircraft   = 4,
     &                      Laircr      =19,
     &                      Lsulf       =LM
      REAL*8, PARAMETER :: correct_CO_ind=520./410.
c
!@var CH4_src           CH4 surface sources and sinks (kg/s)
!@var CO_src             CO surface sources and sinks (kg/s)
!@var Alkenes_src   Alkenes surface sources and sinks (kg/s)
!@var Paraffin_src Paraffin surface sources and sinks (kg/s)
!@var NOx_src           NOx surface sources and sinks (kg/s)
!@var Isoprene_src ISoprene surface sources and sinks (kg/s)
c
c SHOULD PROBABLY USE ntsurfsrc( ) instead of these ...
      integer, parameter :: nch4src     = 14,
     &                      nCOsrc      =  2,
     &                      nAlkenessrc =  3,
     &                      nParaffinsrc=  3,
     &                      nIsoprenesrc=  1,
     &                      nNOxsrc     =  3
      real*8 CO_src(im,jm,nCOsrc),CH4_src(im,jm,nch4src),
     & Alkenes_src(im,jm,nAlkenessrc),Paraffin_src(im,jm,nParaffinsrc),
     & Isoprene_src(im,jm,nIsoprenesrc),NOx_src(im,jm,nNOxsrc)
      END MODULE TRACER_SOURCES

      MODULE LIGHTNING
!@sum  LIGHTNING_COM model variables lightning parameterization
!@auth Colin Price (modelEification by Greg Faluvegi)
!@ver  1.0 (taken from CB436Tds3M23)
      USE RESOLUTION, only : IM,JM,LM,LS1

      IMPLICIT NONE
      SAVE

!@var i_lgt for saving current i index from CLOUDS_DRV
!@var j_lgt for saving current j index from CLOUDS_DRV
!@var JN J at 30 N
!@var JS J at 30 S
!@var I dummy

      INTEGER, PARAMETER :: JS = JM/3 + 1, JN = 2*JM/3
      INTEGER i_lgt, j_lgt, I
      REAL*8, DIMENSION(IM,JM) :: RNOx_lgt
      REAL*8, DIMENSION(LS1+1) :: SRCLIGHT

!@var HGT Pickering vertical lightning distributions (1998)
      REAL*8 HGT(2,2,16)
      DATA (HGT(1,1,I),I=1,16)/8.2,1.9,2.1,1.6,1.1,1.6,3.0,5.8,
     &  7.6,9.6,10.5,12.3,11.8,12.5,8.1,2.3/
      DATA (HGT(1,2,I),I=1,16)/5.8,2.9,2.6,2.4,2.2,2.1,2.3,6.1,
     & 16.5,14.1,13.7,12.8,12.5,2.8,0.9,0.3/
      DATA (HGT(2,1,I),I=1,16)/20.1,2.3,0.8,1.5,3.4,5.3,3.6,3.8,
     &    5.4,6.6,8.3,9.6,12.8,10.0,6.2,0.3/
      DATA (HGT(2,2,I),I=1,16)/5.8,2.9,2.6,2.4,2.2,2.1,2.3,6.1,
     & 16.5,14.1,13.7,12.8,12.5,2.8,0.9,0.3/

      END MODULE LIGHTNING

      subroutine read_CH4_sources(nt,iact)
!@sum reads in CH4 surface sources and sinks
!@auth Jean Lerner
C****
C**** There are 3 monthly sources and 11 annual sources
C**** Annual sources are read in at start and re-start of run only
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,JDperY,im,jm,jday,focean,fearth
      USE LAKES_COM, only: flake
      USE CONSTANT, only: sday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>ch4_src,nsrc=>nch4src
      implicit none
      character*80 title
!@var adj Factors that tune the total amount of individual sources
      logical :: ifirst=.true.
      real*8 adj(nsrc)
      data adj/1.3847,1.0285,3.904,1.659,1.233,1.194,0.999,
!    *  7.2154, 3.7247d-5,3.1399d-4,5.4838d-5,   !Model II prime
     *  7.2154, 3.5997d-5,17.330d-4,5.3558d-5,
     *  0.4369,0.7533,0.9818/
!@var nanns,nmons: number of annual and monthly input files
      integer, parameter :: nanns=11,nmons=3
      integer ann_units(nanns-3),mon_units(nmons)
      character*12 :: ann_files(nanns-3) =
     *  (/'CH4_ANIMALS ','CH4_COALMINE','CH4_GASLEAK ','CH4_GASVENT ',
     *    'CH4_CITYDUMP','CH4_SOIL_ABS','CH4_TERMITES','CH4_COALBURN'/)
      logical :: ann_bins(nanns-3)=(/.true.,.true.,.true.,.true.,
     *        .true.,.true.,.true.,.true./)
      character*8 :: mon_files(nmons) =
     *   (/'CH4_BURN','CH4_RICE','CH4_WETL'/)
      real*8 adj_wet(jm)
      data adj_wet/15*0.6585,16*1.761,15*0.6585/ !zonal adj FOR WETLANDS
      data kwet/14/  !!! position of wetlands array in src
      logical :: mon_bins(nmons)=(/.true.,.true.,.true./)
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,nt,iact,iu,k,kwet,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Annual Sources and sinks
C**** Apply adjustment factors to bring sources into balance
C**** Annual sources are in KG C/M2/Y
C**** Sources need to be kg/m^2 s; convert /year to /s
C****
      if (ifirst) then
        k = 0
        call openunits(ann_files,ann_units,ann_bins,nanns-3)
        do iu = ann_units(1),ann_units(nanns-3)
          k = k+1
          call readt (iu,0,src(1,1,k),im*jm,src(1,1,k),1)
          src(:,:,k) = src(:,:,k)*adj(k)/(sday*JDperY)
        end do
        call closeunits(ann_units,nanns-3)
        ! 3 miscellaneous sources
          k = k+1
          src(:,:,k) = focean(:,:)*adj(k)/(sday*JDperY)
          k = k+1
          src(:,:,k) =  flake(:,:)*adj(k)/(sday*JDperY)
          k = k+1
          src(:,:,k) = fearth(:,:)*adj(k)/(sday*JDperY)
        call openunits(mon_files,mon_units,mon_bins,nmons)
      endif
C****
C**** Monthly sources are interpolated to the current day
C****
C**** Also, Apply adjustment factors to bring sources into balance
C**** Monthly sources are in KG C/M2/S => src in kg/m^2 s
C****
      ifirst = .false.
      j = 0
      do k = nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *    tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
        src(:,:,k) = src(:,:,k)*adj(k)
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
C**** Zonal adjustment for combined wetlands and tundra
C****
      do j=1,jm
        src(:,j,kwet) = src(:,j,kwet)*adj_wet(j)
      end do
      return
      end subroutine read_CH4_sources

      subroutine read_CO_sources(nt,iact)
!@sum reads in CO surface sources and sinks
!@auth Jean Lerner/Greg Faluvegi
C****
C**** There is 1 monthly sources and 1 annual source
C**** Annual sources are read in at start and re-start of run only
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,jday,JDperY,im,jm
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>CO_src,nsrc=>nCOsrc,correct_CO_ind
      implicit none
      character*80 title
      logical :: ifirst=.true.
!@var nanns,nmons: number of annual and monthly input files
      integer, parameter :: nanns=1,nmons=1
      integer ann_units(nanns),mon_units(nmons)
      character*13 :: ann_files(nanns) = (/'CO_INDUSTRIAL'/)
      logical :: ann_bins(nanns)=(/.true./) ! binary file?
      character*10 :: mon_files(nmons) = (/'CO_BIOMASS'/)
      logical :: mon_bins(nmons)=(/.true./) ! binary file?
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,nt,iact,iu,k,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Annual Sources and sink
C**** I believe this source is already in (kg CO)/m2/sec, so no
C**** conversion needed.  However, Lee put in a correction factor of
C**** 520/410 = correct_CO_ind, so put that in here:
C****
      if (ifirst) then
        call openunits(ann_files,ann_units,ann_bins,nanns)
        k = 0
        do iu = ann_units(1),ann_units(nanns)
          k = k+1
          call readt (iu,0,src(1,1,k),im*jm,src(1,1,k),1)
          src(:,:,k) = src(:,:,k)*correct_CO_ind
        end do
        call closeunits(ann_units,nanns)
        call openunits(mon_files,mon_units,mon_bins,nmons)
      endif
C****
C**** Monthly sources are interpolated to the current day
C**** I believe this source is already in (kg CO)/m2/sec, so no
C**** conversion needed:
C****
      ifirst = .false.
      j = 0
      do k=nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *    tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
      return
      end subroutine read_CO_sources

      subroutine read_Alkenes_sources(nt,iact)
!@sum reads in Alkenes surface sources and sinks
!@auth Jean Lerner/Greg Faluvegi
C****
C**** There are 2 monthly sources and 1 annual source
C**** Annual sources are read in at start and re-start of run only
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,jday,JDperY,im,jm
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE GEOM, only: BYDXYP
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>Alkenes_src,nsrc=>nAlkenessrc
      implicit none
      character*80 title
      logical :: ifirst=.true.
!@var nanns,nmons: number of annual and monthly input files
!@param r3600 = 1.d0/3600.
      real*8, parameter :: r3600=1./3600.
      integer, parameter :: nanns=1,nmons=2
      integer ann_units(nanns),mon_units(nmons)
      character*18 :: ann_files(nanns) = (/'Alkenes_INDUSTRIAL'/)
      logical :: ann_bins(nanns)=(/.true./) ! binary files?
      character*18 :: mon_files(nmons) = (/'Alkenes_BIOMASS   ',
     &                                     'Alkenes_VEGETATION'/)
      logical :: mon_bins(nmons)=(/.true.,.true./) ! binary files?
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,jj,nt,iact,iu,k,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Annual Sources and sink
C**** I believe input file is in (kg C)/4x5 grid/hr. So,
C**** convert to (kg C)/m2/s.
C****
      if (ifirst) then
        call openunits(ann_files,ann_units,ann_bins,nanns)
        k = 0
        do iu = ann_units(1),ann_units(nanns)
          k = k+1
          call readt (iu,0,src(1,1,k),im*jm,src(1,1,k),1)
          do j = 1,jm
            src(:,j,k) = src(:,j,k)*BYDXYP(j)*r3600
          end do
        end do
        call closeunits(ann_units,nanns)
        call openunits(mon_files,mon_units,mon_bins,nmons)
      endif
C****
C**** Monthly sources are interpolated to the current day
C**** I believe input files are in (kg C)/4x5 grid/hr. So,
C**** convert to (kg C)/m2/s.
C****
      ifirst = .false.
      j = 0
      do k=nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *    tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
          do jj = 1,jm
            src(:,jj,k) = src(:,jj,k)*BYDXYP(jj)*r3600
          end do
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
      return
      end subroutine read_Alkenes_sources

      subroutine read_Paraffin_sources(nt,iact)
!@sum reads in Paraffin surface sources and sinks
!@auth Jean Lerner/Greg Faluvegi
C****
C**** There are 2 monthly sources and 1 annual source
C**** Annual sources are read in at start and re-start of run only
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,jday,JDperY,im,jm
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE GEOM, only: BYDXYP
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>Paraffin_src,nsrc=>nParaffinsrc
      implicit none
      character*80 title
      logical :: ifirst=.true.
!@var nanns,nmons: number of annual and monthly input files
!@var r3600 = 1.d0/3600.
      integer, parameter :: nanns=1,nmons=2
      real*8, parameter :: r3600=1./3600.
      integer ann_units(nanns),mon_units(nmons)
      character*19 :: ann_files(nanns) = (/'Paraffin_INDUSTRIAL'/)
      logical :: ann_bins(nanns)=(/.true./) ! binary files?
      character*19 :: mon_files(nmons) = (/'Paraffin_BIOMASS   ',
     &                                     'Paraffin_VEGETATION'/)
      logical :: mon_bins(nmons)=(/.true.,.true./) ! binary files?
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,jj,nt,iact,iu,k,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Annual Sources and sink
C**** I believe input file is in (kg C)/4x5 grid/hr. So,
C**** convert to (kg C)/m2/s.
C****
      if (ifirst) then
        call openunits(ann_files,ann_units,ann_bins,nanns)
        k = 0
        do iu = ann_units(1),ann_units(nanns)
          k = k+1
          call readt (iu,0,src(1,1,k),im*jm,src(1,1,k),1)
          do j = 1,jm
            src(:,j,k) = src(:,j,k)*BYDXYP(j)*r3600
          end do
        end do
        call closeunits(ann_units,nanns)
        call openunits(mon_files,mon_units,mon_bins,nmons)
      endif
C****
C**** Monthly sources are interpolated to the current day
C**** I believe input files are in (kg C)/4x5 grid/hr. So,
C**** convert to (kg C)/m2/s.
C****
      ifirst = .false.
      j = 0
      do k=nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *  tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
        do jj = 1,jm
          src(:,jj,k) = src(:,jj,k)*BYDXYP(jj)*r3600
        end do
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
      return
      end subroutine read_Paraffin_sources

      subroutine read_Isoprene_sources(nt,iact)
!@sum reads in Isoprene surface sources and sinks
!@auth Jean Lerner/Greg Faluvegi
C****
C**** There is 1 monthly source
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,jday,JDperY,im,jm
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE GEOM, only: BYDXYP
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>Isoprene_src,nsrc=>nIsoprenesrc
      implicit none
      character*80 title
      logical :: ifirst=.true.
!@var nanns,nmons: number of annual and monthly input files
!@var r3600 = 1.d0/3600.
      real*8, parameter :: r3600=1./3600.
      integer, parameter :: nanns=0, nmons=1
      integer mon_units(nmons)
      character*19 :: mon_files(nmons) = (/'Isoprene_VEGETATION'/)
      logical :: mon_bins(nmons)=(/.true./) ! binary file?
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,jj,nt,iact,iu,k,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Monthly sources are interpolated to the current day
C****
C**** I believe input files are in (kg C)/4x5 grid/hr. So,
C**** convert to (kg C)/m2/s.
C****
      if(ifirst) call openunits(mon_files,mon_units,mon_bins,nmons)
      ifirst = .false.
      j = 0
      do k=nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *    tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
        do jj = 1,jm
          src(:,jj,k) = src(:,jj,k)*BYDXYP(jj)*r3600
        end do
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
      return
      end subroutine read_Isoprene_sources

      subroutine read_NOx_sources(nt,iact)
!@sum reads in NOx surface sources and sinks
!@auth Jean Lerner/Greg Faluvegi
C****
C**** There are 2 monthly sources and 1 annual source
C**** Annual sources are read in at start and re-start of run only
C**** Monthly sources are interpolated each day
      USE MODEL_COM, only: itime,jday,JDperY,im,jm
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE TRACER_COM, only: itime_tr0,trname
      use TRACER_SOURCES, only: src=>NOx_src,nsrc=>nNOxsrc
      implicit none
      character*80 title
      logical :: ifirst=.true.
!@var nanns,nmons: number of annual and monthly input files
      integer, parameter :: nanns=1,nmons=2
      integer ann_units(nanns),mon_units(nmons)
      character*15 :: ann_files(nanns) = (/'NOx_FOSSIL_FUEL'/)
      logical :: ann_bins(nanns)=(/.true./) ! binary files?
      character*11 :: mon_files(nmons) = (/'NOx_BIOMASS',
     &                                     'NOx_SOIL   '/)
      logical :: mon_bins(nmons)=(/.true.,.true./) ! binary files?
      real*8 tlca(im,jm,nmons),tlcb(im,jm,nmons)  ! for monthly sources
      real*8 frac
      integer i,j,nt,iact,iu,k,imon(nmons)
      integer :: jdlast=0
      save ifirst,jdlast,tlca,tlcb,mon_units,imon

      if (itime.lt.itime_tr0(nt)) return
C****
C**** Annual Sources and sink
C**** The titles of the input file say this is in KG/Y/m2, so convert
C**** yr-1 to s-1:
C****
      if (ifirst) then
        call openunits(ann_files,ann_units,ann_bins,nanns)
        k = 0
        do iu = ann_units(1),ann_units(nanns)
          k = k+1
          call readt (iu,0,src(1,1,k),im*jm,src(1,1,k),1)
          src(:,:,k) = src(:,:,k)/(sday*JDperY)
        end do
        call closeunits(ann_units,nanns)
        call openunits(mon_files,mon_units,mon_bins,nmons)
      endif
C****
C**** Monthly sources are interpolated to the current day
C**** The titles of the input files say this is in KG/m2/s, so no
C**** conversion is necessary:
C****
      ifirst = .false.
      j = 0
      do k=nanns+1,nsrc
        j = j+1
        call read_monthly_sources(mon_units(j),jdlast,
     *    tlca(1,1,j),tlcb(1,1,j),src(1,1,k),frac,imon(j))
      end do
      jdlast = jday
      write(6,*) trname(nt),'Sources interpolated to current day',frac
      call sys_flush(6)
C****
      return
      end subroutine read_NOx_sources
c
c
      SUBROUTINE get_lightning_NOx
!@sum  get_lightning_NOx to define the 3D source of NOx from lightning
!@auth Colin Price / Greg Faluvegi
!@ver  1.0 (based on CB436Tds3M23 & DB396Tds3M23)
c
C**** GLOBAL parameters and variables:
      USE FLUXES, only        : tr3Dsource
      USE TRACER_COM, only    : n_NOx
      USE TRACER_SOURCES, only: nLightning
      USE LIGHTNING, only     : HGT,JS,JN,SRCLIGHT,RNOx_lgt
      USE CONSTANT, only      : bygrav
      USE MODEL_COM, only     : fland,IM,JM,LS1
      USE DYNAMICS, only      : LTROPO, PHI
      USE GEOM, only          : BYDXYP
c
      IMPLICIT NONE
c
C**** Local parameters and variables and arguments:
c
!@var LATINDX Pickering latitude index
!@var LANDINDX Pickering surface type index
!@var IH Picjering altitude index
!@var HEIGHT Picjering HGT variable specific to I,J,L, point
!@var LEVTROP local variable to hold the tropopause level
!@var ALTTROP altitude of tropopause
!@var ALTTOP altitude at the top of ?
!@var I,J,L loop indicies in x,y,z directions
!@var GCMHT altitude of gcm levels
!@param pmin2psec to convert from min-1 to sec-1
      REAL*8, PARAMETER :: pmin2psec = 1.D0/60.D0
      INTEGER LATINDX,LANDINDX,IH,LEVTROP,I,J,L
      REAL*8, DIMENSION(16) :: HEIGHT
      REAL*8 :: ALTTROP,ALTTOP,GCMHT
c
      DO J=1,JM
      DO I=1,IM
C****    Lightning source function altitude dependence:
C****    Determine if latitude is tropical:
         IF(J.GT.JS.AND.J.LE.JN) THEN
           LATINDX=1
         ELSE
           LATINDX=2
         END IF
C****    Determine if over land or ocean:
         IF(fland(I,J).GE.0.5) THEN
           LANDINDX=1
         ELSE
            LANDINDX=2
         END IF
C****    Choose appropriate height file:
         DO IH=1,16
          HEIGHT(IH)=HGT(LATINDX,LANDINDX,IH)*0.01
         ENDDO
C****    Store local tropopause
         LEVTROP=LTROPO(I,J)
         ALTTROP=PHI(I,J,LEVTROP)*BYGRAV*1.E-3
         IF(ALTTROP.EQ.0.) GOTO 1510
C****    Zero source accumulator
         SRCLIGHT = 0. ! 1 to LS1+1 levels
C        Determine which GCM level the height belongs to
         DO 1505 IH=1,16
           L=1
 1502      continue
           GCMHT=PHI(I,J,L)*BYGRAV*1.E-3
           IF(ALTTROP.LT.GCMHT)GCMHT=ALTTROP
           ALTTOP=
     &     (PHI(I,J,L)+(PHI(I,J,L+1)-PHI(I,J,L))*.5)*BYGRAV*1.E-3
c          RNOx_lgt is gN/min added per grid box (lightning NOx):
           IF(IH.LE.ALTTOP)THEN
             SRCLIGHT(L)=SRCLIGHT(L)+RNOx_lgt(I,J)*HEIGHT(IH)
             goto 1505
           elseif(IH-1.LT.ALTTOP)then
             SRCLIGHT(L)=SRCLIGHT(L)+RNOx_lgt(I,J)*HEIGHT(IH)*
     &       (ALTTOP-IH+1.)
             SRCLIGHT(L+1)=SRCLIGHT(L+1)+RNOx_lgt(I,J)*HEIGHT(IH)*
     &       (IH-ALTTOP)
             goto 1505
           else
             L=L+1
           ENDIF
           goto 1502
 1505    continue
 1510    continue
C        save tracer 3D source. convert from gN/min to kgN/s/m2 :
         DO L=1,LS1+1
           tr3Dsource(I,J,L,nLightning,n_NOx) =
     &     SRCLIGHT(L)*pmin2psec*BYDXYP(J)
         END DO
      END DO ! I
      END DO ! J

C
      END SUBROUTINE get_lightning_NOx
c
c
      SUBROUTINE get_aircraft_NOx
!@sum  get_aircraft_NOx to define the 3D source of NOx from aircraft
!@auth Drew Shindell? / Greg Faluvegi / Jean Learner
!@ver  1.0 (based on DB396Tds3M23)
c
C**** GLOBAL parameters and variables:
C
      USE MODEL_COM, only: itime,jday,JDperY,im,jm,lm,ptop
      USE CONSTANT, only: sday,hrday
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      USE FLUXES, only: tr3Dsource
      USE DYNAMICS, only   : PMID
      USE GEOM, only       : dxyp
      USE TRACER_COM, only: itime_tr0,trname,n_NOx
      use TRACER_SOURCES, only: nAircraft,Laircr
C
      IMPLICIT NONE
c
!@var nanns,nmons: number of annual and monthly input files
!@var l,ll dummy loop variable
!@var pres local pressure variable
      character*80 title
      logical LINJECT
      integer, parameter :: nanns=0,nmons=1
      integer ann_units(nanns),mon_units(nmons)
      character*12 :: mon_files(nmons) = (/'NOx_AIRCRAFT'/)
      logical :: mon_bins(nmons)=(/.true./) ! binary file?
      real*8 tlca(im,jm,Laircr,nmons),tlcb(im,jm,Laircr,nmons)
      real*8 frac
      integer l,i,j,iu,k,ll,imon(nmons)
      integer :: jdlast=0
      save jdlast,tlca,tlcb,mon_units,imon
      REAL*8, DIMENSION(IM,JM,Laircr,1) :: src
      REAL*8, DIMENSION(LM)     :: pres
      REAL*4, DIMENSION(Laircr) :: PAIRL
      DATA PAIRL/1013.25,898.74,794.95,701.08,616.40,540.19,471.81,
     &            410.60,355.99,307.42,264.36,226.32,193.30,165.10,
     &            141.01,120.44,102.87,87.866,75.048/
c
C**** Local parameters and variables and arguments:
c
C**** Aircraft NOx source input is monthly, on 19 levels. Therefore:
C     19x12=228 records. Read it in here and interpolated each day.

      if (itime.lt.itime_tr0(n_NOx)) return

C****
C**** Monthly sources are interpolated to the current day
C**** The titles of the input files say this is in KG/m2/s, so no
C**** conversion is necessary:
C****
      call openunits(mon_files,mon_units,mon_bins,nmons)
      j = 0
      do k=nanns+1,1
        j = j+1
        call read_monthly_3Dsources(Laircr,mon_units(j),jdlast,
     *    tlca(1,1,1,j),tlcb(1,1,1,j),src(1,1,1,k),frac,imon(j))
      end do
      jdlast = jday
      call closeunits(mon_units,nmons)
      write(6,*)trname(n_NOx),'frm aircraft interpd to currnt day',frac
      call sys_flush(6)
C====
C====   Place aircraft sources onto model levels:
C====
      DO J=1,JM
       DO I=1,IM
        DO L=1,LM
          tr3Dsource(i,j,l,nAircraft,n_NOx) = 0.
          if(L.LT.LM) then
            PRES(L)=PMID(L+1,I,J) !Pressure @ layer top?
          else
            PRES(L)=PTOP
          endif
        ENDDO   ! L
        tr3Dsource(i,j,1,nAircraft,n_NOx) = SRC(I,J,1,1)*dxyp(j)
        DO LL=2,Laircr
          LINJECT=.TRUE.
          DO L=1,LM
           IF(PAIRL(LL).GT.PRES(L).AND.LINJECT) THEN
             tr3Dsource(i,j,l,nAircraft,n_NOx) =
     &       tr3Dsource(i,j,l,nAircraft,n_NOx) + SRC(I,J,LL,1)*dxyp(j)
             LINJECT=.FALSE.
           ENDIF
          ENDDO ! L
        ENDDO   ! LL
       END DO   ! I
      END DO    ! J
C
      return
      END SUBROUTINE get_aircraft_NOx
C
C
      SUBROUTINE get_sulfate
!@sum  get_sulfate to parameterize N2O5 sink on sulfate.  The sulfate( )
!@+    array is then used in the chemistry to calculate a chemical
!@+    change.  I.e. this source is not applied directly to the tracer
!@+    mass like other 3D sources are.
!@auth Drew Shindell? / Greg Faluvegi
!@ver  1.0 (based on DB396Tds3M23)
c
C**** GLOBAL parameters and variables:
C
      USE MODEL_COM, only: jday,im,jm,lm
      USE FILEMANAGER, only: openunit,closeunit, openunits,closeunits
      use TRACER_SOURCES, only: Lsulf
      USE TRCHEM_Shindell_COM, only: sulfate
C
      IMPLICIT NONE
c
C**** Local parameters and variables and arguments:
c
!@var nanns,nmons: number of annual and monthly input files
      character*80 title
      integer, parameter :: nanns=0,nmons=1
      integer ann_units(nanns),mon_units(nmons)
      character*10 :: mon_files(nmons) = (/'SULFATE_SA'/)
      logical :: mon_bins(nmons)=(/.true./) ! binary file?
      real*8 tlca(im,jm,Lsulf,nmons),tlcb(im,jm,Lsulf,nmons)
      real*8 frac
      integer i,j,iu,k,imon(nmons)
      integer :: jdlast=0
      REAL*8, DIMENSION(IM,JM,Lsulf,1) :: src
      save jdlast,tlca,tlcb,mon_units,imon
c
C**** Sulfate surface area input file is monthly, on LM levels.
C     Read it in here and interpolated each day.
C****
C**** Monthly sources are interpolated to the current day
C**** I belive no conversion of the sulfate input file is expected:
C****
      call openunits(mon_files,mon_units,mon_bins,nmons)
      j = 0
      do k=nanns+1,1
        j = j+1
        call read_monthly_3Dsources(Lsulf,mon_units(j),jdlast,
     *    tlca(1,1,1,j),tlcb(1,1,1,j),src(1,1,1,k),frac,imon(j))
      end do
      jdlast = jday
      call closeunits(mon_units,nmons)
      write(6,*) 'Sulfate srface area interpolated to current day',frac
      call sys_flush(6)
C
C**** Save in array to be used in chemistry:
C
      sulfate(:,:,:)=src(:,:,:,1)
C
      return
      END SUBROUTINE get_sulfate
C
C
      SUBROUTINE read_monthly_3Dsources(Ldim,iu,jdlast,tlca,tlcb,data1,
     & frac,imon)
!@sum Read in monthly sources and interpolate to current day
!@+   Calling routine must have the lines:
!@+      real*8 tlca(im,jm,Ldim,nm),tlcb(im,jm,Ldim,nm)
!@+      integer imon(nm)   ! nm=number of files that will be read
!@+      data jdlast /0/
!@+      save jdlast,tlca,tlcb,imon
!@+   Input: iu, the fileUnit#; jdlast
!@+   Output: interpolated data array + two monthly data arrays
!@auth Jean Lerner and others / Greg Faluvegi
      USE MODEL_COM, only: jday,im,jm,idofm=>JDmidOfM
      implicit none
!@var Ldim how many vertical levels in the read-in file?
!@var L dummy vertical loop variable
      integer Ldim,L
      real*8 frac, A2D(im,jm), B2D(im,jm)
      real*8 tlca(im,jm,Ldim),tlcb(im,jm,Ldim),data1(im,jm,Ldim)
      integer imon,iu,jdlast
C
      if (jdlast.EQ.0) then   ! NEED TO READ IN FIRST MONTH OF DATA
        imon=1                ! imon=January
        if (jday.le.16)  then ! JDAY in Jan 1-15, first month is Dec
          DO L=1,Ldim
            call readt(iu,0,A2D,im*jm,A2D,11*Ldim+L)
            tlca(:,:,L)=A2d(:,:)
            rewind iu
          END DO
        else              ! JDAY is in Jan 16 to Dec 16, get first month
  120     imon=imon+1
          if (jday.gt.idofm(imon) .AND. imon.le.12) go to 120
          DO L=1,Ldim-1
            call readt(iu,0,A2D,im*jm,A2D,(imon-1)*Ldim+L)
            tlca(:,:,L)=A2d(:,:)
            rewind iu
          END DO
          if (imon.eq.13)  rewind iu
        end if
      else                         ! Do we need to read in second month?
        if (jday.ne.jdlast+1) then ! Check that data is read in daily
          if (jday.ne.1 .OR. jdlast.ne.365) then
            write(6,*)
     *      'Bad values in Tracer 3D Source:JDAY,JDLAST=',JDAY,JDLAST
            call stop_model('Bad values in Tracer 3D Source.',255)
          end if
          imon=imon-12             ! New year
          go to 130
        end if
        if (jday.le.idofm(imon)) go to 130
        imon=imon+1                ! read in new month of data
        tlca(:,:,:) = tlcb(:,:,:)
        if (imon.eq.13) rewind iu
      end if
      DO L=1,Ldim
        call readt(iu,0,B2D,im*jm,B2D,1)
        tlcb(:,:,L)=B2D(:,:)
      END DO
  130 continue
c**** Interpolate two months of data to current day
      frac = float(idofm(imon)-jday)/(idofm(imon)-idofm(imon-1))
      data1(:,:,:) = tlca(:,:,:)*frac + tlcb(:,:,:)*(1.-frac)
      return
      end subroutine read_monthly_3Dsources

      subroutine get_CH4_IC
!@sum get_CH4_IC to generate initial conditions for methane.
!@+ >>WARNING<<: This routine is still mostly 'hard coded' for the
!@+ 4 x 5, 23 layer model. It needs to be generalized!
!@auth Greg Faluvegi/Drew Shindell
!@ver  1.0 (based on DB396Tds3M23)
c
C**** GLOBAL parameters and variables:
C
      USE RESOLUTION, only : im,jm,lm,ls1
      USE MODEL_COM, only  : JEQ
      USE GEOM, only       : dxyp
      USE DYNAMICS, only   : am
      USE CONSTANT, only: mair
      USE TRACER_COM, only : trm, TR_MM, n_CH4
c
      IMPLICIT NONE
c
C**** Local parameters and variables and arguments:
c
!@var CH4INIT temp variable for ch4 initial conditions
!@var j2 dummy
!@var I,J,L dummy loop variables
!@param bymair 1/molecular wt. of air = 1/mair
      REAL*8, PARAMETER :: bymair = 1.d0/mair
      REAL*8 CH4INIT
      INTEGER J2, I, J, L

      WRITE(6,*) '>>WARNING : you are using CH4 initial condition in'
      WRITE(6,*) 'the stratosphere which are specific to the 4x5 deg,'
      WRITE(6,*) '23-layer model. Otherwise, subroutine get_CH4_IC'
      WRITE(6,*) 'needs to be generalized. <<'

C     First, the troposphere:
      DO L=1,LS1-1
      DO J=1,JM
C       Initial latitudinal gradient for CH4:
        IF(J.LT.JEQ)THEN ! Southern Hemisphere
          CH4INIT=1.75 *TR_MM(n_CH4)*bymair*1.E-6*DXYP(J)
        ELSE             ! Northern Hemisphere
          CH4INIT=1.855*TR_MM(n_CH4)*bymair*1.E-6*DXYP(J)
        ENDIF
        DO I=1,IM
          trm(i,j,l,n_CH4)=am(L,I,J)*CH4INIT
        END DO
      END DO
      END DO
c
C     Now, the stratosphere:
      do L=LS1,LM
      do j=1,jm
        j2=NINT((FLOAT(j)-1.)/3.)
         if(j.le.2) j2=1
         if(j.ge.45)j2=14
c
c     Define stratospheric ch4 based on HALOE obs for tropics
c     and extratropics and scale by the ratio of initial troposphere
c     mixing ratios to 1.79 (observed). The 12 "stratospheric" levels
c     are grouped into 4 categories: L={12,13,14} based on 100mb obs.
c     L={15,16,17} on 32mb obs, L={18,19,20} on 3.2mb obs and
c     L={21,22,23} on 0.32mb obs (average of mar,jun,sep,dec).
        IF(J.LT.JEQ)THEN ! Southern Hemisphere
          CH4INIT=1.75/1.79  *TR_MM(n_CH4)*bymair*1.E-6*DXYP(J)
        ELSE             ! Northern Hemisphere
          CH4INIT=1.855/1.79 *TR_MM(n_CH4)*bymair*1.E-6*DXYP(J)
        ENDIF
        IF((J.LE.16).OR.(J.GT.30)) THEN               ! extratropics
          IF((L.GE.LS1).AND.(L.LE.14)) CH4INIT=CH4INIT*1.700!was1.44
          IF((L.GE.15).AND.(L.LE.17))  CH4INIT=CH4INIT*   1.130
          IF((L.GE.18).AND.(L.LE.20))  CH4INIT=CH4INIT*   0.473
          IF((L.GE.21).AND.(L.LE.LM))  CH4INIT=CH4INIT*   0.202
        ELSE IF((J.GT.16).AND.(J.LE.30)) THEN           ! tropics
          IF((L.GE.LS1).AND.(L.LE.14)) CH4INIT=CH4INIT*   1.620
          IF((L.GE.15).AND.(L.LE.17))  CH4INIT=CH4INIT*   1.460
          IF((L.GE.18).AND.(L.LE.20))  CH4INIT=CH4INIT*   0.812
          IF((L.GE.21).AND.(L.LE.LM))  CH4INIT=CH4INIT*   0.230
        END IF
        do i=1,im
          trm(i,j,l,n_CH4)= am(L,I,J)*CH4INIT
        end do ! i
      end do   ! j
      end do   ! l
      j2=0
      RETURN
      end subroutine get_CH4_IC

      SUBROUTINE calc_lightning(LMAX,LFRZ,IC)
!@sum calc_lightning to calculate lightning flash amount and cloud-
!@+   to-ground amount, based on cloud top height. WARNING: this
!@+   routine is apparently resolution dependant.  See the comments.
!@auth Colin Price (modelEifications by Greg Faluvegi)
!@ver  1.0 (based on CB436Tds3M23)
C
C**** GLOBAL parameters and variables:
C
      USE LIGHTNING, only : i_lgt,j_lgt,JN,JS,RNOx_lgt
      USE MODEL_COM, only : fland
      USE GEOM,      only : bydxyp
      USE CONSTANT,  only : bygrav
      USE DYNAMICS,  only : gz
c
      IMPLICIT NONE
c
C**** Local parameters and variables and arguments:
C
!@var LMAX highest layer of current convective cloud event
!@var lmax_temp local copy of LMAX (alterable)
!@var LFRZ freezing level
!@var HTCON height of convection?
!@var HTFRZ height of freezing?
!@var lightning flashes per minute
!@var th,th2,th3,th4 thickness of cold sector, squared, cubed, etc.
!@var CG fraction of lightning that is cloud-to-ground
!@var zlt ?
!@var IC interger for cloud types
      INTEGER, INTENT(IN) :: LMAX,LFRZ,IC
      INTEGER lmax_temp
      REAL*8 HTCON,HTFRZ,flash,th,th2,th3,th4,zlt,CG
C
c The folowing simple algorithm calculates the lightning
c frequency in each gridbox using the moist convective cloud
c scheme.  The algorithm is based on the Price and Rind (1992)
c JGR paper, and differentiates between oceanic and continental
c convective clouds.  Only the non-entraining plume is used for
c the lightning:

      If (IC.eq.2) RETURN

c The lightning calculation uses the maximum height of the cloud,
c or the maximum depth of the mass flux penetration, LMAX, at
c every timestep.  In each timestep there may be a number of
c different values of LMAX, associated with clouds originating
c from different levels.  However, there are always less values
c of LMAX then the number of vertical layers. gz is the
c geopotential height, used from DYNAMICS module.

      lmax_temp=lmax
      if(j_lgt.lt.JS.or.j_lgt.gt.JN)lmax_temp=lmax+1 !30 S to 30 N
      HTCON=gz(i_lgt,j_lgt,lmax_temp)*bygrav*1.E-3
      HTFRZ=gz(i_lgt,j_lgt,LFRZ+1)*bygrav*1.E-3

c IF the gridbox is over land or coastline use the continental
c parameterization.  The factor 2.17 is derived from Fig. 1
c of the Price and Rind (1994) Mon. Wea. Rev. paper, and is
c related to the horizontal resolution of the GCM (in this case
c 4x5 degrees).  We use a threshold of 1% for continental
c gridboxes. The units are flashes per minute.

      If (fland(i_lgt,j_lgt).le.0.01) then
        flash=2.17*6.2e-4*(htcon**1.73)
      else
        flash=2.17*3.44e-5*(htcon**4.92)
      end if

c The formulation by Price and Rind (1993) in Geophysical Res.
c Letters is used to calculate the fraction of total lightning
c that is cloud-to-ground lightning.  This uses the thickness of
c cold sector of the cloud (Hmax-Hzero) as the determining
c parameter.  The algorithm is only valid for thicknesses greater
c than 5.5km and less than 14km.

      th=(HTCON-HTFRZ)
      If (th.lt.5.5) th=5.5
      If (th.gt.14.) th=14.
      th2=th*th
      th3=th2*th
      th4=th3*th
      zlt=0.021*th4-0.648*th3+7.493*th2-36.544*th+63.088
      CG=flash/(1.+zlt)

c Given the number of cloud-to-ground flashes, we can now calculate
c the NOx production rate based on the Price et al. (1997) JGR paper.
c The units are grams of Nitrogen per minute:

      RNOx_lgt(i_lgt,j_lgt)=15611.*(CG + 0.1*(flash-CG))

C These diagnostics need to be put back in:
c note CG & flash OUTPUT now in units: flashes/[time]/m2
c      AIJ(i,j,97)=aij(i,j,97) + flash*BYDXYP(J)
c      AIJ(i,j,98)=aij(i,j,98) + CG*BYDXYP(J)

      END SUBROUTINE calc_lightning
c
c
      SUBROUTINE get_sza(I,J,tempsza)
!@sum get_sza calculates the solar angle.  The intention is
!@+   that this routine will only be used when the COSZ1 from the
!@+   radiation code is < 0, i.e. SZA > 90 deg.
!@auth Greg Faluvegi, based on the Harvard CTM routine SCALERAD
!@ver 1.0

c
C**** GLOBAL parameters and variables:
C
      USE MODEL_COM, only: JDAY, JHOUR, IM, JM
      USE CONSTANT, only: PI, radian
      USE TRCHEM_Shindell_COM, only: byradian
      IMPLICIT NONE
c
C**** Local parameters and variables and arguments
C
!@param ANG1 ?
!@var DX degree width of a model grid cell (360/IM)
!@var DY degree width of a model grid cell ~(180/JM)
!@var tempsza the solar zenith angle, returned in degrees
!@var P1,P2,P3 ? angles needed to compute COS(SZA) in degrees
!@var VLAT,VLOM latitude and longitude in degrees
!@var current julian time in seconds
!@var FACT,temp are temp variables
      REAL*8, PARAMETER ::  ANG1 = 90.d0/91.3125d0
      REAL*8 P1,P2,P3,VLAT,VLON,TIMEC,FACT,temp
      REAL*8, INTENT(OUT) :: tempsza
      INTEGER, INTENT(IN) :: I,J
      INTEGER DX,DY

      DX   = NINT(360./REAL(IM))
      DY   = NINT(180./REAL(JM))
      vlat = -90. + REAL((J-1)*DY)
      if (J.eq.1)  vlat= -90. + 0.5*REAL(DY)
      if (j.eq.JM) vlat=  90. - 0.5*REAL(DY)
      VLON = 180. - REAL((I-1)*DX)
C     This added 0.5 is to make the instantaneous zenith angle
C     more representative throughout the 1 hour time step:
      TIMEC = ((JDAY*24.0) + JHOUR  + 0.5)*3600.
      P1 = 15.*(TIMEC/3600. - VLON/15. - 12.)
      FACT = (TIMEC/86400. - 81.1875)*ANG1
      P2 = 23.5*SIN(FACT*radian)
      P3 = VLAT
      temp = (SIN(P3*radian)*SIN(P2*radian)) +
     &(COS(P1*radian)*COS(P2*radian)*COS(P3*radian))
      tempsza = acos(temp)*byradian

      RETURN
      END SUBROUTINE get_sza


      SUBROUTINE SFCBKGD(bgmodel,t,q,height,tsfc,qsfc_i,
     &                   tdsfc_i,tdsfc_o,ter,p,IMX,JMX,KX,psfc,
     &                   nx_pr,ny_pr,istatus)

c inputs are from laps analyzed 2- 3d fields
C     INPUT       t        ANALYZED TEMPERATURE     3D
C                 q        Analyzed MIXING RATIO    3D
C                 height   ANALYZED HEIGHT          3D
C                 qsfc_i   Q Surface                2D
C                 ter      TERRAIN                  2D
C                 IMX      DIMENSION E-W
C                 JMX      DIMENSION N-S
C                 KX       NUMBER OF VERTICAL LEVELS
C                 p        LAPS Pressure levels     1D/3D (Pa)
c
c Compute surface variables on hi-res terrain using first 3D model level
c above the LAPS terrain. This routine is also called for reduced pressure
c where 'ter' is passed in as a constant array.

c
c J. Smart    09-22-98:	Original Version: This is used to compute
c                       sfc p for lgb when using NOGAPS1.0 deg since
c                       this field currently does not come with the
c                       model grids at AFWA.
c    "        02-01-99: Recompute tdsfc with new psfc and tsfc for
c                       consistency.
c    "        11-18-99: Put psfc,tsfc, and tdsfc comps into subroutine
c
      IMPLICIT NONE

      INTEGER    I
      INTEGER    IMX
      INTEGER    J
      INTEGER    JMX
      INTEGER    K
      INTEGER    KX
      INTEGER    nx_pr,ny_pr,ip,jp
      INTEGER    it, idebug, istatus, ishow_timer
      INTEGER    istat_qsfc_i, istat_tdsfc_i
      INTEGER    bgmodel

      LOGICAL    lfndz

      REAL       HEIGHT      ( IMX , JMX, KX )
      REAL       P           ( nx_pr,ny_pr,KX ) ! Pa
      REAL       PSFC        ( IMX , JMX )
      REAL       TSFC        ( IMX , JMX )
      REAL       Q           ( IMX , JMX , KX )
      REAL       rh3d        ( IMX , JMX , KX )
      REAL       rh2d        ( IMX , JMX )
      REAL       qsfc_i      ( imx,  jmx )
      REAL       tdsfc_i     ( imx,  jmx )
      REAL       tdsfc_o     ( imx,  jmx )
      REAL       T           ( IMX , JMX , KX )
      REAL       esat
      REAL       TER         ( IMX , JMX )
      REAL       make_td
      REAL       make_rh
      REAL       make_ssh
      REAL       t_ref,badflag
      REAL       tdsfc_o_min, tdsfc_o_max
      REAL       qsfc_i_min, qsfc_i_max
      REAL       p_mb
      REAL       r_missing_data
c
c if bgmodel = 6 or 8 then tdsfc_i is used
c if bgmodel = 4      then qsfc_i is rh (WFO - RUC)
c if bgmodel = 3      then qsfc_i is rh and q is rh
c if bgmodel = 9      then no surface fields input. Compute all from 3d
c                     fields. q3d used. (NOS - ETA)
c otherwise qsfc_i is used directly with a test for g/kg or dimensionless
c
      call get_r_missing_data(r_missing_data,istatus)

      write(6,*)
      write(6,*)' Subroutine sfcbkgd, bgmodel = ',bgmodel

      qsfc_i_min = minval(qsfc_i)
      qsfc_i_max = maxval(qsfc_i)
      write(6,*)' qsfc_i range = ',qsfc_i_min,qsfc_i_max
      if(qsfc_i_min .eq. r_missing_data .AND.
     1   qsfc_i_max .eq. r_missing_data       )then
         write(6,*)' NOTE: qsfc_i has missing data values'
         istat_qsfc_i = 0
      else
         istat_qsfc_i = 1
      endif

      write(6,*)' tdsfc_i range = ',minval(tdsfc_i),maxval(tdsfc_i)
      if(minval(tdsfc_i) .eq. r_missing_data .AND.
     &   maxval(tdsfc_i) .eq. r_missing_data       )then
         write(6,*)' NOTE: tdsfc_i has missing data values'
         istat_tdsfc_i = 0
      else
         istat_tdsfc_i = 1
      endif

      if(istat_qsfc_i .eq. 0 .and. istat_tdsfc_i .eq. 0)then
         write(6,*)
     1           ' WARNING: both qsfc_i and tdsfc_i have missing values'
      endif

      write(6,*)' ter range = ',minval(ter),maxval(ter)

      t_ref=-132.0
      if(bgmodel.eq.3.or.bgmodel.eq.9)then
         write(6,*)' bgmodel is ',bgmodel,' convert 3D q to rh'
         do k=1,kx
            do j=1,jmx
            do i=1,imx
               ip = min(i,nx_pr)
               jp = min(j,ny_pr)
               p_mb = p(ip,jp,k) / 100.
               rh3d(i,j,k)=make_rh(p_mb,t(i,j,k)-273.15,q(i,j,k)*1000.
     +,t_ref)*100.
            enddo
            enddo
         enddo

         badflag=0.
         write(6,*)
     1  ' Interp 3D T and RH to hi-res terrain, set tdsfc_o array to RH'
         write(6,*)' height bottom level range = '
     1             ,minval(height(:,:,1)),maxval(height(:,:,1))
         call interp_to_sfc(ter,rh3d,height,imx,jmx,kx,
     &                      badflag,tdsfc_o) ! Here tdsfc_o temporarily is RH
         call interp_to_sfc(ter,t,height,imx,jmx,kx,badflag,
     &                      tsfc)
      endif

      istatus = ishow_timer()

      write(6,*)' Compute sfc fields using 3D model data'

      idebug = 1

      do j=1,jmx
      do i=1,imx
         k=0
         lfndz=.false.
         do while(.not.lfndz)
            k=k+1
            if(height(i,j,k).gt.ter(i,j))then
               lfndz=.true.

               if(k.gt.0)then

                  call compute_sfc_bgfields(bgmodel,imx,jmx,kx,i,j,k
     &                ,ter(i,j),height,t,p,q,t_ref,psfc(i,j),tsfc(i,j)
     &                ,qsfc_i(i,j),qsfc_i_min,qsfc_i_max,istat_qsfc_i
     &                ,tdsfc_i(i,j),istat_tdsfc_i
     &                ,tdsfc_o(i,j),idebug,ip,jp,nx_pr,ny_pr)

                  idebug = 0

               endif

            endif
            if(k.eq.kx)lfndz=.true.
         enddo
      enddo
      enddo

      istatus = 1

      tdsfc_o_min = minval(tdsfc_o)
      tdsfc_o_max = maxval(tdsfc_o)
      if(tdsfc_o_max .gt. 1000.)then
          write(6,*)' ERROR: tdsfc_o is out of bounds'
          istatus = 0
      endif

      write(6,*)' tdsfc_o range = ',tdsfc_o_min,tdsfc_o_max
      write(6,*)' psfc range = ',minval(psfc),maxval(psfc)

      if(minval(psfc) .lt. 50000.)then
          write(6,*)' ERROR: psfc is out of bounds'
          istatus = 0
      endif

      write(6,*)' returning from sfcbkgd...'
      write(6,*)

      return
      end
c
c----------------------------------------------------------------------------
c
      subroutine compute_sfc_bgfields(bgm,nx,ny,nz,i,j,k,ter,height
     &,t,p,q,t_ref,psfc_pa,tsfc,qsfc,qsfc_i_min,qsfc_i_max,istat_qsfc_i
     &,tdsfc_i,istat_tdsfc_i,tdsfc
     &,idebug,ip,jp,nx_pr,ny_pr)
c
c J. Smart 11/18/99 put existing code in subroutine for other process use in laps
c
      implicit none

      integer nx,ny,nz
      integer i,j,k            !I, i,j,k coordinate of point for calculation
      integer bgm              !I, model type {if = 0, then tdsfc input = qsfc}
      integer nx_pr,ny_pr,ip,jp
      integer istatus, idebug, init_td
      integer istat_qsfc_i,istat_tdsfc_i
      data init_td/0/
      save init_td

      real   p(nx_pr,ny_pr,nz) !I, pressure of levels (Pa)
      real   ter               !I, Terrain height at i,j
      real   t_ref             !I, reference temp for library moisture conv routines

      real   height(nx,ny,nz)  !I, heights of pressure levels 3d
      real   t(nx,ny,nz)       !I, temperatures 3d
      real   q(nx,ny,nz)       !I, specific humidity 3d
      real   psfc_pa           !O, output surface pressure, pa
      real   tsfc              !I/O input sfc T, output recomputed T
      real   qsfc              !I   input sfc Q (g/kg)
      real   tdsfc_i           !I   input sfc Td
      real   tdsfc             !O   hi-res Td (K)

      real   qsfc_l            !L   surface spec hum, Input as q or computed internally (dimensionless)
      real   psfc_mb           !L

      real   tbar,tsfc_c
      real   td1,td2,tdsfc_c
      real   p_mb,p_mb_p1,p_mb_m1
      real   G,R
      real   ssh2,make_ssh,make_td
      real   dz,dzp,dtdz
      real   tvsfc,tvk,tbarv
      real   r_missing_data
      real   qsfc_i_min, qsfc_i_max

      parameter (G         = 9.8,
     &           R         = 287.04)
c
c if first guess values are missing data then return missing data
c
      call get_r_missing_data(r_missing_data,istatus)

      ip = min(i,nx_pr)
      jp = min(j,ny_pr)
      p_mb = p(ip,jp,k) / 100.

      if(tsfc.lt.500.0.and.t(i,j,k).lt.500.0) then
c
c first guess psfc_mb without moisture consideration
c
          tbar=(tsfc+t(i,j,k))*0.5
          dz=height(i,j,k)-ter
          psfc_mb=p_mb*exp(G/(R*tbar)*dz)

!         Calculate qsfc_l according to model (bgm=0 for reduced P)
!         This is used below for virtual temperature and sfc P reduction
          if(istat_qsfc_i .eq. 1)then
           if(bgm.eq.0.or.bgm.eq.6.or.
     &        bgm.eq.8.or.bgm.eq.12)then                   ! qsfc is Td
             tsfc_c  = tsfc-273.15
             tdsfc_c = qsfc-273.15
             if(tdsfc_c .lt. -200.)then ! a la ssh2 error check
                 if(init_td .le. 100)write(6,*)
     1           ' WARNING: setting qsfc_l to zero, tdsfc_c = ',tdsfc_c
                 init_td = init_td + 1
!                tdsfc_c = tsfc_c - 30.
                 qsfc_l = 0.0
             else
                 if(idebug .eq. 1)write(6,*)' qsfc is Td: calling ssh2'
                 qsfc_l=ssh2(psfc_mb,tsfc_c,tdsfc_c,t_ref)*.001 ! kg/kg
             endif

           elseif(bgm.eq.3.or.bgm.eq.4.or.bgm.eq.9)then    ! qsfc is RH
!    1                                .or.bgm.eq.13)then   ! qsfc is RH
             if(idebug .eq. 1)write(6,*)' qsfc is RH: calling make_ssh'
             qsfc_l=make_ssh(psfc_mb,tsfc-273.15
     &                      ,qsfc/100.,t_ref)*.001 !kg/kg

           else                                            ! qsfc is qsfc
             if(qsfc_i_max .gt. .050)then                 ! likely g/kg
                 qsfc_l=qsfc*.001                         ! make dimensionless
                 if(idebug .eq. 1)then
                     write(6,*)
     1                      ' compute_sfc_bgfields: qsfc_l = qsfc*.001 '
     1                        ,qsfc_l,qsfc
                     write(6,*)' thus qsfc_i is assumed g/kg'
                 endif
             else
                 qsfc_l=qsfc                              ! keep dimensionless
                 if(idebug .eq. 1)then
                     write(6,*)' compute_sfc_bgfields: qsfc_l = qsfc '
     1                        ,qsfc_l,qsfc
                     write(6,*)' thus qsfc_i is assumed dimensionless'
                 endif
             endif
           endif

           if(qsfc_l .lt. 0.0 .or. qsfc_l .gt. .050)then
             write(6,*)' WARNING in compute_sfc_bgfields, qsfc_l = '
     1                 ,qsfc_l
             psfc_mb =r_missing_data
             tsfc =r_missing_data
             tdsfc=r_missing_data
           endif

          elseif(istat_tdsfc_i .eq. 1)then ! q is missing, so use td more directly
           tsfc_c  = tsfc-273.15
           tdsfc_c = tdsfc_i-273.15
           qsfc_l=ssh2(psfc_mb,tsfc_c,tdsfc_c,t_ref)*.001 ! kg/kg

          else ! both q and td are missing
           qsfc_l = 0.

          endif ! valid range for qsfc_i

c pressure
          tvsfc=tsfc*(1.+0.608*qsfc_l)
          tvk=t(i,j,k)*(1.+0.608*q(i,j,k))
          tbarv=(tvsfc+tvk)*.5
          psfc_mb=(p_mb*exp(G/(R*tbarv)*dz))

!         if(j .eq. ny/2)then
!             write(6,101)i,tvsfc,tvk,tbarv,height(i,j,k),dz,p_mb,psfc_pa
!    1                   ,(psfc_pa/100.-p_mb) / dz
!101          format(' i,tvsfc,tvk,tbarv,ht,dz,pk,psfc',i4,6f8.2,f9.2
!    1                                                 ,e15.6)
!         endif

          if(k.gt.1)then ! calculate tsfc,qsfc

             dzp=height(i,j,k)-height(i,j,k-1)
c temp
             dtdz=(t(i,j,k-1)-t(i,j,k))/dzp
             tsfc=t(i,j,k)+dtdz*dz

c dew point temp
             td2=make_td(p_mb,t(i,j,k)-273.15,q(i,j,k)*1000.,t_ref)
             p_mb_m1 = p(ip,jp,k-1) / 100.
             td1=make_td(p_mb_m1,t(i,j,k-1)-273.15,q(i,j,k-1)*1000.
     .,t_ref)
             tdsfc=td2+((td1-td2)/dzp)*dz+273.15

             if(idebug .eq. 1)then
                 write(6,*)' k/tdsfc (C) = ',k,tdsfc
             endif
c
          else ! k=1: calculate tsfc,qsfc and psfc_mb

             dzp=height(i,j,k+1)-height(i,j,k)
             p_mb_p1 = p(ip,jp,k+1) / 100.
             td2=make_td(p_mb,t(i,j,k)-273.15
     &,q(i,j,k)*1000.,t_ref)+273.15
             td1=make_td(p_mb_p1,t(i,j,k+1)-273.15
     &,q(i,j,k+1)*1000.,t_ref)+273.15
             dtdz=(t(i,j,k)-t(i,j,k+1))/dzp
             tsfc=t(i,j,k)+dtdz*dz
             tbar=(tsfc+t(i,j,k))*0.5
             psfc_mb=p_mb*exp(G/(R*tbar)*dz)
             tdsfc=td2+((td1-td2)/dzp)*dz

             if(idebug .eq. 1)then
                 write(6,*)' k/tdsfc = ',k,tdsfc
             endif

          endif

          if(psfc_mb .ne. r_missing_data)then
             psfc_pa = psfc_mb * 100.
          else
             psfc_pa = r_missing_data
          endif

       else
          psfc_pa =r_missing_data
          tsfc =r_missing_data
          tdsfc=r_missing_data
       endif

       return

       end


C$Procedure GFUDB ( GF, user defined boolean )

      SUBROUTINE GFUDB ( UDFUNS, UDFUNB, STEP, CNFINE, RESULT )

C$ Abstract
C
C     Perform a GF search on a user defined boolean quantity.
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     GF
C     TIME
C     WINDOWS
C
C$ Keywords
C
C     EVENT
C     EPHEMERIS
C     SEARCH
C     WINDOW
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'gf.inc'
      INCLUDE               'zzgf.inc'
      INCLUDE               'zzholdd.inc'

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      EXTERNAL              UDFUNS
      EXTERNAL              UDFUNB
      DOUBLE PRECISION      STEP
      DOUBLE PRECISION      CNFINE ( LBCELL : * )
      DOUBLE PRECISION      RESULT ( LBCELL : * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     LBCELL     P   SPICE Cell lower bound.
C     CNVTOL     P   Convergence tolerance.
C     UDFUNS     I   Name of the routine that computes a scalar
C                    quantity corresponding to an ET.
C     UDFUNB     I   Name of the routine returning the boolean value
C                    corresponding to an ET.
C     STEP       I   Constant step size in seconds for finding geometric
C                    events.
C     CNFINE     I   SPICE window to which the search is restricted.
C     RESULT    I-O  SPICE window containing results.
C
C$ Detailed_Input
C
C     UDFUNS     the routine that returns the value of the scalar
C                quantity of interest at time ET. The calling sequence
C                for UDFUNC is:
C
C                   CALL UDFUNS ( ET, VALUE )
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 UDFUNS.
C
C                   VALUE   is the value of the scalar quantity
C                           at ET.
C
C     UDFUNB     the user defined routine returning a boolean value
C                for an epoch ET. The calling sequence for UNFUNB is:
C
C                   CALL UDFUNB ( UDFUNS, ET, BOOL )
C
C                where:
C
C                   UDFUNS   the name of the scalar function as
C                            defined above.
C
C                   ET       a double precision value representing
C                            ephemeris time, expressed as seconds past
C                            J2000 TDB, at which to evaluate UDFUNB.
C
C                   BOOL     the boolean value at ET.
C
C                GFUDB will correctly operate only for boolean
C                functions with true conditions defining non zero
C                measure time intervals.
C
C                Note, UDFUNB need not call UDFUNS. The use of UDFUNS
C                is determined by the needs of the calculation and
C                the user's design.
C
C     STEP       the step size to be used in the search. STEP must
C                be shorter than any interval, within the confinement
C                window, over which the user defined boolean function
C                is met. In other words, STEP must be shorter than the
C                shortest time interval for which the boolean function
C                is true; STEP must also be shorter than the shortest
C                time interval between two boolean function true events
C                occurring within the confinement window (see below).
C                However, STEP must not be *too* short, or the search
C                will take an unreasonable amount of time.
C
C                The choice of STEP affects the completeness but not
C                the precision of solutions found by this routine; the
C                precision is controlled by the convergence tolerance.
C                See the discussion of the parameter CNVTOL for
C                details.
C
C                STEP has units of TDB seconds.
C
C     CNFINE     is a SPICE window that confines the time period over
C                which the specified search is conducted. CNFINE may
C                consist of a single interval or a collection of
C                intervals.
C
C                In some cases the confinement window can be used to
C                greatly reduce the time period that must be searched
C                for the desired solution. See the Particulars section
C                below for further discussion.
C
C                See the Examples section below for a code example
C                that shows how to create a confinement window.
C
C                CNFINE must be initialized by the caller via the
C                SPICELIB routine SSIZED.
C
C     RESULT     a double precision SPICE window which will contain the
C                search results. RESULT must be declared and initialized
C                with sufficient size to capture the full set of time
C                intervals within the search region on which the
C                specified constraint is satisfied.
C
C                RESULT must be initialized by the caller via the
C                SPICELIB routine SSIZED.
C
C                If RESULT is non-empty on input, its contents
C                will be discarded before GFUDB conducts its search.
C
C$ Detailed_Output
C
C     RESULT     is a SPICE window containing the time intervals within
C                the confinement window, during which the specified
C                boolean quantity is true.
C
C                If no times within the confinement window satisfy the
C                search, RESULT will be returned with a cardinality
C                of zero.
C
C$ Parameters
C
C     LBCELL     the integer value defining the lower bound for
C                SPICE Cell arrays (a SPICE window is a kind of cell).
C
C     CNVTOL     is the convergence tolerance used for finding
C                endpoints of the intervals comprising the result
C                window. CNVTOL is used to determine when binary
C                searches for roots should terminate: when a root is
C                bracketed within an interval of length CNVTOL, the
C                root is considered to have been found.
C
C                The accuracy, as opposed to precision, of roots found
C                by this routine depends on the accuracy of the input
C                data. In most cases, the accuracy of solutions will be
C                inferior to their precision.
C
C     See INCLUDE file gf.inc for declarations and descriptions of
C     parameters used throughout the GF system.
C
C$ Exceptions
C
C     1)  In order for this routine to produce correct results,
C         the step size must be appropriate for the problem at hand.
C         Step sizes that are too large may cause this routine to miss
C         roots; step sizes that are too small may cause this routine
C         to run unacceptably slowly and in some cases, find spurious
C         roots.
C
C         This routine does not diagnose invalid step sizes, except
C         that if the step size is non-positive, the error
C         SPICE(INVALIDSTEP) is signaled.
C
C     2)  Due to numerical errors, in particular,
C
C            - truncation error in time values
C            - finite tolerance value
C            - errors in computed geometric quantities
C
C         it is *normal* for the condition of interest to not always be
C         satisfied near the endpoints of the intervals comprising the
C         RESULT window. One technique to handle such a situation,
C         slightly contract RESULT using the window routine WNCOND.
C
C     3)  If the size of the SPICE window RESULT is less than 2 or
C         not an even value, the error SPICE(INVALIDDIMENSION) will
C         signal. If RESULT has insufficient capacity to contain the
C         number of intervals on which the specified condition
C         is met, the error will be diagnosed by a routine in the call
C         tree of this routine.
C
C     4)  If required ephemerides or other kernel data are not
C         available, an error is signaled by a routine in the call tree
C         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     If the boolean function requires access to ephemeris data:
C
C        - SPK data: ephemeris data for any body over the
C          time period defined by the confinement window must be
C          loaded. If aberration corrections are used, the states of
C          target and observer relative to the solar system barycenter
C          must be calculable from the available ephemeris data.
C          Typically ephemeris data are made available by loading one
C          or more SPK files via FURNSH.
C
C        - If non-inertial reference frames are used, then PCK
C          files, frame kernels, C-kernels, and SCLK kernels may be
C          needed.
C
C     In all cases, kernel data are normally loaded once per program
C     run, NOT every time this routine is called.
C
C$ Particulars
C
C     This routine determines a set of one or more time intervals
C     within the confinement window when the boolean function
C     evaluates to true. The resulting set of intervals is returned
C     as a SPICE window.
C
C     Below we discuss in greater detail aspects of this routine's
C     solution process that are relevant to correct and efficient
C     use of this routine in user applications.
C
C     UDFUNS Default Template
C     =======================
C
C     The boolean function includes an argument for an input scalar
C     function. Use of a scalar function during the evaluation of
C     the boolean function is not required. SPICE provides a no-op
C     scalar routine, UDF, as a dummy argument for instances when
C     the boolean function does not need to call the scalar function.
C
C     The Search Process
C     ==================
C
C     The search for boolean events is treated as a search for state
C     transitions: times are sought when the boolean function value
C     changes from true to false or vice versa.
C
C     Step Size
C     =========
C
C     Each interval of the confinement window is searched as follows:
C     first, the input step size is used to determine the time
C     separation at which the boolean function will be sampled.
C     Starting at the left endpoint of the interval, samples of the
C     boolean function will be taken at each step. If a state change
C     is detected, a root has been bracketed; at that point, the
C     "root"--the time at which the state change occurs---is found by a
C     refinement process, for example, via binary search.
C
C     Note that the optimal choice of step size depends on the lengths
C     of the intervals over which the boolean function is constant:
C     the step size should be shorter than the shortest such interval
C     and the shortest separation between the intervals, within
C     the confinement window.
C
C     Having some knowledge of the relative geometry of the targets and
C     observer can be a valuable aid in picking a reasonable step size.
C     In general, the user can compensate for lack of such knowledge by
C     picking a very short step size; the cost is increased computation
C     time.
C
C     Note that the step size is not related to the precision with which
C     the endpoints of the intervals of the result window are computed.
C     That precision level is controlled by the convergence tolerance.
C
C
C     Convergence Tolerance
C     =====================
C
C     Once a root has been bracketed, a refinement process is used to
C     narrow down the time interval within which the root must lie.
C     This refinement process terminates when the location of the root
C     has been determined to within an error margin called the
C     "convergence tolerance." The default convergence tolerance
C     used by this routine is set by the parameter CNVTOL (defined
C     in gf.inc).
C
C     The value of CNVTOL is set to a "tight" value so that the
C     tolerance doesn't become the limiting factor in the accuracy of
C     solutions found by this routine. In general the accuracy of input
C     data will be the limiting factor.
C
C     The user may change the convergence tolerance from the default
C     CNVTOL value by calling the routine GFSTOL, e.g.
C
C        CALL GFSTOL( tolerance value )
C
C     Call GFSTOL prior to calling this routine. All subsequent
C     searches will use the updated tolerance value.
C
C     Setting the tolerance tighter than CNVTOL is unlikely to be
C     useful, since the results are unlikely to be more accurate.
C     Making the tolerance looser will speed up searches somewhat,
C     since a few convergence steps will be omitted. However, in most
C     cases, the step size is likely to have a much greater effect
C     on processing time than would the convergence tolerance.
C
C
C     The Confinement Window
C     ======================
C
C     The simplest use of the confinement window is to specify a time
C     interval within which a solution is sought.
C
C     The confinement window also can be used to restrict a search to
C     a time window over which required data are known to be
C     available.
C
C     In some cases, the confinement window can be used to make
C     searches more efficient. Sometimes it's possible to do an
C     efficient search to reduce the size of the time period over
C     which a relatively slow search of interest must be performed.
C     See the "CASCADE" example program in gf.req for a demonstration.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     Use the meta-kernel shown below to load the required SPICE
C     kernels.
C
C           KPL/MK
C
C           File name: standard.tm
C
C           This meta-kernel is intended to support operation of SPICE
C           example programs. The kernels shown here should not be
C           assumed to contain adequate or correct versions of data
C           required by SPICE-based user applications.
C
C           In order for an application to use this meta-kernel, the
C           kernels referenced here must be present in the user's
C           current working directory.
C
C
C           \begindata
C
C              KERNELS_TO_LOAD = ( 'de418.bsp',
C                                  'pck00009.tpc',
C                                  'naif0009.tls'  )
C
C           \begintext
C
C     Example(1):
C
C     Calculate the time intervals when the position of the moon
C     relative to the earth in the IAU_EARTH frame has a positive value
C     for the Z position component, also with a positive value for the
C     Vz velocity component.
C
C
C        Code:
C
C           PROGRAM GFUDB_T
C
C           EXTERNAL                  UDF
C           EXTERNAL                  GFB
C
C     C
C     C     Local parameters
C     C
C           INTEGER               LBCELL
C           PARAMETER           ( LBCELL = -5 )
C
C     C
C     C     Use the parameter MAXWIN for both the result window size and
C     C     the workspace size.
C     C
C           INTEGER               MAXWIN
C           PARAMETER           ( MAXWIN = 100 )
C
C           DOUBLE PRECISION      LEFT
C           DOUBLE PRECISION      RIGHT
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      ETS
C           DOUBLE PRECISION      ETE
C           DOUBLE PRECISION      STEP
C           DOUBLE PRECISION      STATE (6)
C           DOUBLE PRECISION      CNFINE ( LBCELL : 2 )
C           DOUBLE PRECISION      RESULT ( LBCELL : MAXWIN )
C
C           INTEGER               I
C
C           CHARACTER*(32)        UTC
C
C     C
C     C     SPICELIB functions.
C     C
C           INTEGER               WNCARD
C           DOUBLE PRECISION      SPD
C
C     C
C     C     Initialize windows.
C     C
C           CALL SSIZED ( MAXWIN, RESULT )
C           CALL SSIZED ( 2,      CNFINE )
C
C
C     C
C     C     Load needed kernels.
C     C
C           CALL FURNSH ( 'standard.tm' )
C
C     C
C     C     Store the time bounds of our search interval in
C     C     the confinement window. One year, 2011.
C     C
C           CALL STR2ET ( 'Jan 1 2011', ETS )
C           CALL STR2ET ( 'Jan 1 2012', ETE )
C           CALL WNINSD ( ETS, ETE, CNFINE )
C
C     C
C     C     The moon orbit about the earth-moon barycenter is
C     C     twenty-eight days. The event condition occurs
C     C     during (very) approximately a quarter of the orbit. Use
C     C     a step of five days.
C     C
C           STEP = 5.D0 * SPD()
C
C           CALL GFUDB ( UDF, GFB, STEP, CNFINE, RESULT )
C
C           IF ( WNCARD(RESULT) .EQ. 0 ) THEN
C
C                 WRITE (*, '(A)') 'Result window is empty.'
C
C           ELSE
C
C              DO I = 1, WNCARD(RESULT)
C
C     C
C     C           Fetch and display each RESULT interval.
C     C
C                 CALL WNFETD ( RESULT, I, LEFT, RIGHT )
C                 WRITE (*,*) 'Interval ', I
C
C                 CALL ET2UTC ( LEFT, 'C', 4, UTC )
C                 WRITE (*, *) '   Interval start: ', UTC
C
C                 CALL SPKEZ ( 301, LEFT, 'IAU_EARTH', 'NONE', 399,
C          .                   STATE, LT )
C                 WRITE (*, *) '                Z= ', STATE(3)
C                 WRITE (*, *) '               Vz= ', STATE(6)
C
C                 CALL ET2UTC ( RIGHT, 'C', 4, UTC )
C                 WRITE (*, *) '   Interval end  : ', UTC
C
C                 CALL SPKEZ ( 301, RIGHT, 'IAU_EARTH', 'NONE', 399,
C          .                   STATE, LT )
C                 WRITE (*, *) '                Z= ', STATE(3)
C                 WRITE (*, *) '               Vz= ', STATE(6)
C                 WRITE (*, *) ' '
C
C              END DO
C
C           END IF
C
C           END
C
C
C
C     C-Procedure GFB
C     C
C     C     User defined boolean routine.
C     C
C
C           SUBROUTINE GFB ( UDFUNS, ET, BOOL )
C           IMPLICIT NONE
C
C     C- Abstract
C     C
C     C     User defined geometric boolean function:
C     C
C     C        Z >= 0 with dZ/dt > 0.
C     C
C
C           EXTERNAL              UDFUNS
C
C           DOUBLE PRECISION      ET
C           LOGICAL               BOOL
C
C     C
C     C     Local variables.
C     C
C           INTEGER               TARG
C           INTEGER               OBS
C
C           CHARACTER*(12)        REF
C           CHARACTER*(12)        ABCORR
C
C           DOUBLE PRECISION      STATE ( 6 )
C           DOUBLE PRECISION      LT
C
C     C
C     C     Initialization. Retrieve the vector from the earth to
C     C     the moon in the IAU_EARTH frame, without aberration
C     C     correction.
C     C
C           TARG   = 301
C           REF    = 'IAU_EARTH'
C           ABCORR = 'NONE'
C           OBS    = 399
C
C     C
C     C     Evaluate the state of TARG from OBS at ET with
C     C     correction ABCORR.
C     C
C           CALL SPKEZ ( TARG, ET, REF, ABCORR, OBS, STATE, LT )
C
C     C
C     C     Calculate the boolean value.
C     C
C           BOOL = (STATE(3) .GE. 0.D0) .AND. (STATE(6) .GT. 0.D0 )
C
C           RETURN
C
C           END
C
C     The program outputs:
C
C      Interval            1
C         Interval start: 2011 JAN 09 15:24:23.4155
C                      Z=  -3.67969050785177387E-008
C                     Vz=   0.39698408492943960
C         Interval end  : 2011 JAN 16 16:08:28.5634
C                      Z=    156247.48820202681
C                     Vz=   3.76859567857712463E-013
C
C      Interval            2
C         Interval start: 2011 FEB 05 23:17:57.3590
C                      Z=  -3.98442807636456564E-008
C                     Vz=   0.39678128322307005
C         Interval end  : 2011 FEB 13 01:38:28.4256
C                      Z=    157016.05516171581
C                     Vz=   3.22388166509868235E-013
C
C      Interval            3
C         Interval start: 2011 MAR 05 06:08:17.6680
C                      Z=  -1.16190221888246015E-008
C                     Vz=   0.39399025399881443
C         Interval end  : 2011 MAR 12 10:27:45.1887
C                      Z=    157503.77393430873
C                     Vz=  -3.41879302645509142E-013
C
C                        ...
C
C      Interval           12
C         Interval start: 2011 NOV 05 18:43:39.7428
C                      Z=  -1.80199890564836096E-008
C                     Vz=   0.37393762954280635
C         Interval end  : 2011 NOV 13 03:50:17.1540
C                      Z=    153172.08661820635
C                     Vz=  -3.62962481251227764E-013
C
C      Interval           13
C         Interval start: 2011 DEC 03 01:16:40.8174
C                      Z=   1.30391470065660542E-007
C                     Vz=   0.37425784503188919
C         Interval end  : 2011 DEC 10 09:51:07.7182
C                      Z=    152511.72037686800
C                     Vz=   2.11386680729064302E-013
C
C      Interval           14
C         Interval start: 2011 DEC 30 09:48:57.4099
C                      Z=   9.79434844339266419E-009
C                     Vz=   0.37733320145276139
C         Interval end  : 2012 JAN 01 00:00:00.0000
C                      Z=    50793.083312689421
C                     Vz=   0.35454996926793847
C
C
C     Example(2):
C
C     Calculate the time intervals when the Z component of the earth
C     to moon position vector in the IAU_EARTH frame has value
C     between -1000 km and 1000 km (e.g. above and below the equatorial
C     plane).
C
C
C        Code:
C
C           PROGRAM GFUDB_T2
C
C           EXTERNAL                  GFB
C           EXTERNAL                  GFQ
C
C     C
C     C     Local parameters
C     C
C           INTEGER               LBCELL
C           PARAMETER           ( LBCELL = -5 )
C
C     C
C     C     Use the parameter MAXWIN for both the result window size
C     C     and the workspace size.
C     C
C           INTEGER               MAXWIN
C           PARAMETER           ( MAXWIN = 100 )
C
C           DOUBLE PRECISION      LEFT
C           DOUBLE PRECISION      RIGHT
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      ETS
C           DOUBLE PRECISION      ETE
C           DOUBLE PRECISION      STEP
C           DOUBLE PRECISION      POS (3)
C           DOUBLE PRECISION      CNFINE ( LBCELL : 2 )
C           DOUBLE PRECISION      RESULT ( LBCELL : MAXWIN )
C
C           INTEGER               I
C
C           CHARACTER*(32)        UTC
C
C     C
C     C     SPICELIB functions.
C     C
C           INTEGER               WNCARD
C           DOUBLE PRECISION      SPD
C
C     C
C     C     Initialize windows.
C     C
C           CALL SSIZED ( MAXWIN, RESULT )
C           CALL SSIZED ( 2,      CNFINE )
C
C
C     C
C     C     Load needed kernels.
C     C
C           CALL FURNSH ( 'standard.tm' )
C
C     C
C     C     Store the time bounds of our search interval in
C     C     the confinement window. One year, 2011.
C     C
C           CALL STR2ET ( 'Jan 1 2011', ETS )
C           CALL STR2ET ( 'Jan 1 2012', ETE )
C           CALL WNINSD ( ETS, ETE, CNFINE )
C
C     C
C     C     The duration of the event is approximately ninety minutes.
C     C     Use a step of one hour.
C     C
C           STEP = 60.D0*60.D0
C
C           CALL GFUDB ( GFQ, GFB, STEP, CNFINE, RESULT )
C
C           IF ( WNCARD(RESULT) .EQ. 0 ) THEN
C
C                 WRITE (*, '(A)') 'Result window is empty.'
C
C           ELSE
C
C              DO I = 1, WNCARD(RESULT)
C
C     C
C     C           Fetch and display each RESULT interval.
C     C
C                 CALL WNFETD ( RESULT, I, LEFT, RIGHT )
C                 WRITE (*,*) 'Interval ', I
C
C                 CALL ET2UTC ( LEFT, 'C', 4, UTC )
C                 WRITE (*, *) '   Interval start: ', UTC
C
C                 CALL SPKEZP ( 301, LEFT, 'IAU_EARTH', 'NONE', 399,
C          .                   POS, LT )
C                 WRITE (*, *) '                Z= ', POS(3)
C
C                 CALL ET2UTC ( RIGHT, 'C', 4, UTC )
C                 WRITE (*, *) '   Interval end  : ', UTC
C
C                 CALL SPKEZP ( 301, RIGHT, 'IAU_EARTH', 'NONE', 399,
C          .                   POS, LT )
C                 WRITE (*, *) '                Z= ', POS(3)
C                 WRITE (*, *) ' '
C
C              END DO
C
C           END IF
C
C           END
C
C
C
C     C-Procedure GFQ
C     C
C     C     User defined scalar routine.
C     C
C
C           SUBROUTINE GFQ ( ET, VALUE )
C           IMPLICIT NONE
C
C     C- Abstract
C     C
C     C     Return the Z component of the POS vector.
C     C
C
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      VALUE
C
C     C
C     C     Local variables.
C     C
C           INTEGER               TARG
C           INTEGER               OBS
C
C           CHARACTER*(12)        REF
C           CHARACTER*(12)        ABCORR
C
C           DOUBLE PRECISION      POS ( 3 )
C           DOUBLE PRECISION      LT
C
C     C
C     C     Initialization. Retrieve the vector from the earth to
C     C     the moon in the IAU_EARTH frame, without aberration
C     C     correction.
C     C
C           TARG   = 301
C           REF    = 'IAU_EARTH'
C           ABCORR = 'NONE'
C           OBS    = 399
C
C     C
C     C     Evaluate the position of TARG from OBS at ET with
C     C     correction ABCORR.
C     C
C           CALL SPKEZP ( TARG, ET, REF, ABCORR, OBS, POS, LT )
C
C           VALUE = POS(3)
C
C           RETURN
C           END
C
C
C
C     C-Procedure GFB
C     C
C     C     User defined boolean routine.
C     C
C
C           SUBROUTINE GFB ( UDFUNS, ET, BOOL )
C           IMPLICIT NONE
C
C     C- Abstract
C     C
C     C     User defined boolean function:
C     C
C     C        VALUE >= LIM1 with VALUE <= LIM2.
C     C
C
C           EXTERNAL              UDFUNS
C
C           DOUBLE PRECISION      ET
C           LOGICAL               BOOL
C           DOUBLE PRECISION      VALUE
C
C
C           DOUBLE PRECISION      LIM1
C           DOUBLE PRECISION      LIM2
C
C           LIM1 = -1000.D0
C           LIM2 =  1000.D0
C
C           CALL UDFUNS ( ET, VALUE )
C
C     C
C     C     Calculate the boolean value.
C     C
C           BOOL = (VALUE .GE. LIM1) .AND. (VALUE .LE. LIM2 )
C
C           RETURN
C           END
C
C     The program outputs:
C
C      Interval            1
C         Interval start: 2011 JAN 09 14:42:24.4846
C                      Z=   -999.99999990308515
C         Interval end  : 2011 JAN 09 16:06:22.5021
C                      Z=    1000.0000000900436
C
C      Interval            2
C         Interval start: 2011 JAN 23 04:07:44.4554
C                      Z=    1000.0000001154267
C         Interval end  : 2011 JAN 23 05:23:06.2437
C                      Z=   -1000.0000001147444
C
C      Interval            3
C         Interval start: 2011 FEB 05 22:35:57.1561
C                      Z=   -999.99999997469570
C         Interval end  : 2011 FEB 05 23:59:57.7487
C                      Z=    999.99999989149978
C
C                        ...
C
C      Interval           25
C         Interval start: 2011 DEC 03 00:32:08.8206
C                      Z=   -999.99999987966544
C         Interval end  : 2011 DEC 03 02:01:12.7695
C                      Z=    999.99999987608885
C
C      Interval           26
C         Interval start: 2011 DEC 17 10:17:24.0390
C                      Z=    1000.0000000822058
C         Interval end  : 2011 DEC 17 11:40:37.2235
C                      Z=   -999.99999997521718
C
C      Interval           27
C         Interval start: 2011 DEC 30 09:04:47.2759
C                      Z=   -1000.0000000487748
C         Interval end  : 2011 DEC 30 10:33:07.6707
C                      Z=    999.99999986779312
C
C     Recall the default convergence tolerance for the GF system has
C     value 10^-6 seconds.
C
C$ Restrictions
C
C     1) Any kernel files required by this routine must be loaded
C        (normally via the SPICELIB routine FURNSH) before this routine
C        is called.
C
C$ Literature_References
C
C    None.
C
C$ Author_and_Institution
C
C    N.J. Bachman   (JPL)
C    E.D. Wright    (JPL)
C
C$ Version
C
C-   SPICELIB Version 1.0.0, 15-JUL-2014 (EDW)
C
C-&

C$ Index_Entries
C
C   GF user defined boolean function search
C
C-&

C
C     SPICELIB functions.
C
      LOGICAL               ODD
      LOGICAL               RETURN
      INTEGER               SIZED

C
C     Local variables.
C
      EXTERNAL              GFREFN
      EXTERNAL              GFREPF
      EXTERNAL              GFREPI
      EXTERNAL              GFREPU
      EXTERNAL              GFSTEP

      DOUBLE PRECISION      TOL
      LOGICAL               OK

      LOGICAL               GFBAIL
      EXTERNAL              GFBAIL

      LOGICAL               NOBAIL
      PARAMETER           ( NOBAIL = .FALSE. )

      LOGICAL               NORPT
      PARAMETER           ( NORPT  = .FALSE. )

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

      CALL CHKIN( 'GFUDB' )

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

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

      END IF

C
C     Set the step size.
C
      CALL GFSSTP (STEP)

C
C     Retrieve the convergence tolerance, if set.
C
      CALL ZZHOLDD ( ZZGET, GF_TOL, OK, TOL )

C
C     Use the default value CNVTOL if no stored tolerance value.
C
      IF ( .NOT. OK ) THEN

         TOL = CNVTOL

      END IF

C
C     Initialize the RESULT window to empty.
C
      CALL SCARDD ( 0, RESULT)

      CALL ZZGFUDB ( UDFUNS, UDFUNB, TOL,     GFSTEP,  GFREFN,
     .               NORPT,  GFREPI,  GFREPU,  GFREPF,
     .               NOBAIL, GFBAIL,  CNFINE,  RESULT )

      CALL CHKOUT( 'GFUDB' )

      RETURN
      END