c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine hop(ithistraj,istep,time,nclu,nsurf,newsurf,
     &    pem,gpem,dvec,xx,pp,tau)

c Perform a successful or a frustrated hop from NSURF to NEWSURF.
c For a successful hop, NSURF is set to NEWSURF and PP is adjusted
c   to conserve energy.
c For a frustrated hop, NSURF is unchanged, and PP is adjusted for
c   a reflected-and-hop-back.  PP is unchanged for an ingored
c   frustrated hop.

      implicit none
      include 'param.f'
      include 'c_sys.f'

c input
      integer nclu,nsurf,newsurf,ithistraj,istep
      double precision time,xx(3,mnat),tau

c input/output
      double precision pp(3,mnat)

c local
      integer frusflag
      integer i,j
      double precision dxi
      double precision pem(mnsurf),gpem(3,mnat,mnsurf),
     & dvec(3,mnat,mnsurf,mnsurf),r(3),
     & sectrm,a,b,a2,ab,ra,radi,scr,tmp,deltae,dot1,dot2

c new
      double precision radi2,c,sectrm2,ppvib(3,mnat),scr2,deltae2

c compute distance matrix for output
      if (nclu.eq.3) call rtox(xx,r,1)

c check for forbidden hops
        deltae = pem(newsurf) - pem(nsurf)

        do i=1,3
        do j=1,nclu
          ppvib(i,j)=pp(i,j)
        enddo
        enddo
        call noang(xx,ppvib,mm,nclu)

        a=0.0d0
        b=0.0d0
        c=0.0d0
        do i=1,3
        do j=1,nclu
          scr=dvec(i,j,nsurf,newsurf)/mm(j)
c         a = momentum.dot.dvec/mass
c         b = dvec.dot.dvec/mass
c         c = pvib.dot.pvib/mass
          a=a+scr*pp(i,j)
          b=b+scr*dvec(i,j,nsurf,newsurf)
          c=c+ppvib(i,j)*ppvib(i,j)/mm(j)
        enddo
        enddo
        a2=a*a
        ab=a/b
c       sectrm = deltae/kinetic energy along d
        sectrm = 2.0d0*deltae*b/a2
        deltae2=deltae-a2/(2.d0*b)
        sectrm2 = deltae2/(c/2.d0-a2/(2.d0*b))
        radi = 1.0d0-sectrm
        radi2 = 1.0d0-sectrm2
c       if radi > 0 then delta > kinetic energy along d, so we can hop
c       note that for a hop down, sectrm is negative, so we can always hop
        if(radi.ge.0.0d0) then
c         successful hop
          write(6,*)"HOP!",nsurf," ---> ",newsurf
          write(33,1033)ithistraj,istep,time*autofs,"H",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
 1033     format(i5,i10,f12.3,1x,a,2i5,5f12.3)
          radi=sqrt(radi)
          ra=ab*(1.0d0-radi)
          do i=1,3
          do j=1,nclu
           pp(i,j) = pp(i,j) - dvec(i,j,nsurf,newsurf)*ra
          enddo
          enddo
          nsurf = newsurf

c NEW NEW NEW
c currently set up to skip this part
c        elseif(radi2.ge.0.0d0) then
        elseif(.false.) then
c modified successful hop
          write(6,*)"NEW HOP!",nsurf," ---> ",newsurf
          write(33,1033)ithistraj,istep,time*autofs,"V",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
c         take out all the KE along d first
          do i=1,3
          do j=1,nclu
           pp(i,j) = pp(i,j) - dvec(i,j,nsurf,newsurf)*ab
          enddo
          enddo
c         now take out energy along ppvib
          do i=1,3
          do j=1,nclu
            ppvib(i,j)=pp(i,j)
          enddo
          enddo
          call noang(xx,ppvib,mm,nclu)
        a=0.0d0
        b=0.0d0
        do i=1,3
        do j=1,nclu
          scr=ppvib(i,j)/mm(j)
c         a = momentum.dot.dvec/mass
c         b = dvec.dot.dvec/mass
          a=a+scr*pp(i,j)
          b=b+scr*ppvib(i,j)
        enddo
        enddo
        a2=a*a
        ab=a/b
c       sectrm = deltae/kinetic energy along d
        sectrm = 2.0d0*deltae2*b/a2
        radi = 1.0d0-sectrm
          radi=sqrt(radi)
          ra=ab*(1.0d0-radi)
          do i=1,3
          do j=1,nclu
           pp(i,j) = pp(i,j) - ppvib(i,j)*ra
          enddo
          enddo

          nsurf = newsurf
c END NEW NEW NEW

        else
c         frustrated hop
c NOTE:   FRUSFLAG IS HARDCODED
c         FRUSFLAG = 0 --->  IGNORE ALL FRUSTRATED HOPS (I.E., "+")
c         FRUSFLAG = 1 --->  REFLECT ALL FRUSTRATED HOPS (I.E., "-")
c         FRUSFLAG = 2 --->  GRADV FOR ALL FRUSTRATED HOPS (I.E., "gV")
          if (methflag.eq.1) then
c           for FS we use "+"
            frusflag = 0
          else if (methflag.eq.5) then
c           for FSTU we use "gradV"
            frusflag = 2
          else
            write(6,*)"METHFLAG != 1 or 5 in HOP"
            stop
          endif
          if (frusflag.eq.0) then
c           do nothing
            write(6,*)"FRUST! IGNORE"
          write(33,1033)ithistraj,istep,time*autofs,"I",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
          elseif (frusflag.eq.1) then
c           frustrated hop, reflect
            write(6,*)"FRUST! REFLECT"
          write(33,1033)ithistraj,istep,time*autofs,"R",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
            ra=2.0d0*ab
            do i=1,3
            do j=1,nclu
              pp(i,j) = pp(i,j) - dvec(i,j,nsurf,newsurf)*ra
            enddo
            enddo
          elseif (frusflag.eq.2) then
c           gradV method
c           dot1 is the gradient of the NEWSURF in the direction of dvec
            dot1 = 0.d0
            do i=1,3
            do j=1,nclu
              dot1 = dot1 + gpem(i,j,newsurf)*dvec(i,j,nsurf,newsurf)
            enddo
            enddo
c           dot2 is the momentum in the direction of dvec
            dot2 = 0.d0
            do i=1,3
            do j=1,nclu
              dot2 = dot2 + pp(i,j)*dvec(i,j,nsurf,newsurf)
            enddo
            enddo
            if (dot1*dot2.gt.0.d0) then
c           reflect
            write(6,*)"FRUST! REFLECT"
          write(33,1033)ithistraj,istep,time*autofs,"R",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
            ra=2.0d0*ab
            do i=1,3
            do j=1,nclu
              pp(i,j) = pp(i,j) - dvec(i,j,nsurf,newsurf)*ra
            enddo
            enddo
            else
            write(6,*)"FRUST! IGNORE"
          write(33,1033)ithistraj,istep,time*autofs,"I",nsurf,
     &      newsurf,pem(nsurf)*autoev,pem(newsurf)*autoev,tau*autofs
c           ignore
            endif
          else
            write(6,*)"FRUSFLAG = ",frusflag," in HOPCHECK"
            stop
          endif
        endif

      return
      end


C$Procedure      ZZGFILU ( GF, illumination angle utilities )

      SUBROUTINE ZZGFILU ( METHOD, ANGTYP, TARGET, ILLUM, FIXREF,
     .                     ABCORR, OBSRVR, SPOINT, ET,    UDFUNC,
     .                     DECRES, ANGLE                          )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     This is the umbrella routine for the entry points used by
C     GFEVNT in order to find illumination angle events.
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     NAIF_IDS
C     SPK
C     TIME
C
C$ Keywords
C
C     ANGLE
C     EPHEMERIS
C     GEOMETRY
C     SEARCH
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'zzabcorr.inc'

      CHARACTER*(*)         METHOD
      CHARACTER*(*)         ANGTYP
      CHARACTER*(*)         TARGET
      CHARACTER*(*)         ILLUM
      CHARACTER*(*)         FIXREF
      CHARACTER*(*)         ABCORR
      CHARACTER*(*)         OBSRVR
      DOUBLE PRECISION      SPOINT ( 3 )
      DOUBLE PRECISION      ET
      EXTERNAL              UDFUNC
      LOGICAL               DECRES
      DOUBLE PRECISION      ANGLE

C$ Brief_I/O
C
C     VARIABLE  I/O  Entry points
C     --------  ---  --------------------------------------------------
C     METHOD     I   ZZGFILIN
C     ANGTYP     I   ZZGFILIN
C     TARGET     I   ZZGFILIN
C     ILLUM      I   ZZGFILIN
C     FIXREF     I   ZZGFILIN
C     ABCORR     I   ZZGFILIN
C     OBSRVR     I   ZZGFILIN
C     SPOINT     I   ZZGFILIN
C     ET         I   ZZGFILLT, ZZGFILGQ
C     UDFUNC     I   ZZGFILDC
C     REF        I   ZZGFILIN
C     DECRES     O   ZZGFILDC
C     ANGLE      O   ZZGFILGQ
C
C$ Detailed_Input
C
C     See individual entry points.
C
C$ Detailed_Output
C
C     See individual entry points.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     See individual entry points.
C
C$ Files
C
C     Appropriate kernels must be loaded by the calling program before
C     this routine is called.
C
C     The following data are required:
C
C        - SPK data: ephemeris data for target, observer, and
C          illumination source, for the times at which state or
C          positions are computed, must be loaded. If aberration
C          corrections are used, the states of target and observer
C          relative to the solar system barycenter must be calculable
C          from the available ephemeris data. Typically ephemeris data
C          are made available by loading one or more SPK files via
C          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 is an umbrella for routines required by the GF scalar
C     quantity search algorithm to support searches involving
C     illumination angle constraints.
C
C     The entry points of this routine are:
C
C        ZZGFILIN   Saves the user-supplied inputs defining the
C                   illumination angle computation to be performed.
C                   Initializes the illumination angle search.
C
C        ZZGFILDC   Determines whether or not a specified illumination
C                   angle is decreasing at a specified epoch.
C
C        ZZGFILGQ   Returns the specified illumination angle
C                   at a specified epoch.
C
C$ Examples
C
C     See GFEVNT.
C
C$ Restrictions
C
C     This is a SPICELIB private routine; it should not be called by
C     user applications.
C
C     ZZGFILIN must be called prior to use of any of the other
C     entry points.
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.1.0 08-MAR-2017 (NJB)
C
C        Bug fixes: added FAILED checks in entry points ZZGFILIN,
C        ZZGFILDC, and ZZGFILGQ.
C
C        Removed unused declaration of parameter SUN.
C
C
C-    SPICELIB Version 1.0.0 23-MAY-2012 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     umbrella routine for finding illumination angle events.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               ESRCHC

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               BDNMLN
      PARAMETER           ( BDNMLN = 36 )

      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN = 32 )

      INTEGER               MTHLEN
      PARAMETER           ( MTHLEN = 200 )

C
C     Indices of illumination angles in the ANGLES
C     array:
C
      INTEGER               PHSIDX
      PARAMETER           ( PHSIDX = 1 )

      INTEGER               INCIDX
      PARAMETER           ( INCIDX = 2 )

      INTEGER               EMTIDX
      PARAMETER           ( EMTIDX = 3 )

      INTEGER               NAMLEN
      PARAMETER           ( NAMLEN = 50 )

C
C     Local Variables
C
      CHARACTER*(NAMLEN)    ANGNMS ( 3 )
      CHARACTER*(CORLEN)    SVCORR
      CHARACTER*(BDNMLN)    SVINAM
      CHARACTER*(MTHLEN)    SVMETH
      CHARACTER*(BDNMLN)    SVONAM
      CHARACTER*(FRNMLN)    SVREF
      CHARACTER*(BDNMLN)    SVTNAM

      DOUBLE PRECISION      ANGLES ( 3 )
      DOUBLE PRECISION      EMISTA ( 2 )
      DOUBLE PRECISION      ETTARG
      DOUBLE PRECISION      INCSTA ( 2 )
      DOUBLE PRECISION      NORMAL ( 3 )
      DOUBLE PRECISION      PHSSTA ( 2 )
      DOUBLE PRECISION      RADII  ( 3 )
      DOUBLE PRECISION      RATE
      DOUBLE PRECISION      SRFVEC ( 3 )
      DOUBLE PRECISION      SVNRML ( 3 )
      DOUBLE PRECISION      SVSSPT ( 3 )

      INTEGER               N
      INTEGER               FXFCDE
      INTEGER               FXCLSS
      INTEGER               FXTYID
      INTEGER               FXCENT
      INTEGER               SVAIDX
      INTEGER               SVOBS
      INTEGER               SVILUM
      INTEGER               SVTARG

      LOGICAL               FOUND
      LOGICAL               SVABLK ( NABCOR )

C
C     Saved Variables
C
      SAVE                  ANGNMS
      SAVE                  SVABLK
      SAVE                  SVAIDX
      SAVE                  SVCORR
      SAVE                  SVILUM
      SAVE                  SVINAM
      SAVE                  SVMETH
      SAVE                  SVNRML
      SAVE                  SVOBS
      SAVE                  SVONAM
      SAVE                  SVREF
      SAVE                  SVSSPT
      SAVE                  SVTARG
      SAVE                  SVTNAM

C
C     Initial values
C
      DATA                  ANGNMS / 'PHASE',
     .                               'INCIDENCE',
     .                               'EMISSION'   /

C
C     This routine should never be called directly.
C
      CALL CHKIN  ( 'ZZGFILU'           )
      CALL SIGERR ( 'SPICE(BOGUSENTRY)' )
      CALL CHKOUT ( 'ZZGFILU'           )
      RETURN

C$Procedure  ZZGFILIN ( GF, illumination angle utility initialization )

      ENTRY ZZGFILIN ( METHOD, ANGTYP, TARGET, ILLUM,
     .                 FIXREF, ABCORR, OBSRVR, SPOINT )

C$ Abstract
C
C     Initialize the GF illumination angle constraint search utilities.
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     NAIF_IDS
C     SPK
C     TIME
C
C$ Keywords
C
C     ANGLE
C     EPHEMERIS
C     GEOMETRY
C     SEARCH
C
C$ Declarations
C
C      CHARACTER*(*)         TARGET
C      CHARACTER*(*)         ILLUM
C      CHARACTER*(*)         ABCORR
C      CHARACTER*(*)         OBSRVR
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     TARGET     I   Target body name.
C     TARGET     I   Illumination source name.
C     ABCORR     I   Aberration correction specifier.
C     OBSRVR     I   Observer name.
C
C$ Detailed_Input
C
C     TARGET     is the name of a target body. Optionally, you may
C                supply the integer ID code for the object as
C                an integer string. For example both 'MOON' and
C                '301' are legitimate strings that indicate the
C                moon is the target body.
C
C                The target and observer define a position vector
C                which points from the observer to the target.
C
C                Case and leading or trailing blanks are not
C                significant in the string TARGET.
C
C
C     ILLUM      is the name of the illumination source. This source
C                may be any ephemeris object. Case, blanks, and
C                numeric values are treated in the same way as for the
C                input TARGET.
C
C
C     ABCORR     indicates the aberration corrections to be applied
C                when computing the target's position and orientation.
C                Any value accepted by SPKEZR may be used.
C
C                See the header of the SPICE routine SPKEZR for a
C                detailed description of the aberration correction
C                options.
C
C                Case and embedded blanks are not significant in
C                ABCORR.
C
C
C     OBSRVR     is the name of the body from which the occultation is
C                observed. Optionally, you may supply the integer NAIF
C                ID code for the body as a string.
C
C                Case and leading or trailing blanks are not
C                significant in the string OBSRVR.
C
C
C$ Detailed_Output
C
C     None.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If name of the target, observer, or illumination source
C         cannot be translated to a NAIF ID code, the error
C         SPICE(IDCODENOTFOUND) is signaled.
C
C     2)  If  target body coincides with the observer body OBSRVR or
C         the illumination source SOURCE, error
C         SPICE(BODIESNOTDISTINCT) will be signaled.
C
C     3)  If transmission-style aberration corrections are requested,
C         the error SPICE(NOTSUPPORTED) is signaled.
C
C     4)  If the aberration correction string is invalid, the error
C         will be diagnosed by a routine in the call tree of this
C         routine.
C
C     5)  If the illumination angle type is not recognized, the error
C         SPICE(NOTSUPPORTED) will be signaled.
C
C     6)  If the input target body-fixed frame FIXREF is not
C         recognized, the error SPICE(UNKNOWNFRAME) is signaled. A
C         frame name may fail to be recognized because a required frame
C         specification kernel has not been loaded; another cause is a
C         misspelling of the frame name.
C
C     7)  If the input frame FIXREF is not centered at the target body,
C         the error SPICE(INVALIDFRAME) is signaled.
C
C     8)  If the input argument METHOD is not recognized, the error
C         SPICE(INVALIDMETHOD) is signaled.
C
C
C$ Files
C
C     See the header of the umbrella routine ZZGFILU.
C
C$ Particulars
C
C     This routine must be called once before each GF search for
C     illumination angle events.
C
C$ Examples
C
C     See GFEVNT.
C
C$ Restrictions
C
C     This is a SPICELIB private routine; it should not be called by
C     user applications.
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.1.0 08-MAR-2017 (NJB)
C
C        Bug fixes: now checks FAILED after each BODS2C call
C        and after the BODVRD call.
C
C-    SPICELIB Version 1.0.0 23-MAY-2012 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     illumination angle initialization routine
C
C-&

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZGFILIN' )

C
C     Find NAIF IDs for TARGET, OBSRVR, and ILLUM.
C
      CALL BODS2C ( TARGET, SVTARG, FOUND )

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

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The target object, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE Toolkit. '           )
         CALL ERRCH  ( '#', TARGET                                )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'ZZGFILIN'                                 )
         RETURN

      END IF

      CALL BODS2C ( OBSRVR, SVOBS, FOUND )

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

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The observer, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE toolkit. '           )
         CALL ERRCH  ( '#', OBSRVR                                )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'ZZGFILIN'                                 )
         RETURN

      END IF

      CALL BODS2C ( ILLUM, SVILUM, FOUND )

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

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'The illumination source, '
     .   //            '''#'', is not a recognized name for an '
     .   //            'ephemeris object. The cause of this '
     .   //            'problem may be that you need an updated '
     .   //            'version of the SPICE toolkit. '           )
         CALL ERRCH  ( '#', ILLUM                                 )
         CALL SIGERR ( 'SPICE(IDCODENOTFOUND)'                    )
         CALL CHKOUT ( 'ZZGFILIN'                                 )
         RETURN

      END IF

C
C     Make sure the observer and target are distinct.
C
      IF ( SVTARG .EQ. SVOBS ) THEN

         CALL SETMSG ( 'The observer and target must be '
     .   //            'distinct objects, but are not: '
     .   //            'OBSRVR = #; TARGET = #.'           )
         CALL ERRCH  ( '#', OBSRVR                         )
         CALL ERRCH  ( '#', TARGET                         )
         CALL SIGERR ( 'SPICE(BODIESNOTDISTINCT)'          )
         CALL CHKOUT ( 'ZZGFILIN'                          )
         RETURN

      END IF

C
C     Make sure the target and illumination source are distinct.
C
      IF ( SVTARG .EQ. SVILUM ) THEN

         CALL SETMSG ( 'The target and illumination source must '
     .   //            'be distinct objects, but are not: '
     .   //            'TARGET = #; ILLUM = #.'                   )
         CALL ERRCH  ( '#', TARGET                                )
         CALL ERRCH  ( '#', ILLUM                                 )
         CALL SIGERR ( 'SPICE(BODIESNOTDISTINCT)'                 )
         CALL CHKOUT ( 'ZZGFILIN'                                 )
         RETURN

      END IF

C
C     Save the observer, target, and illumination source names.
C
      SVONAM = OBSRVR
      SVTNAM = TARGET
      SVINAM = ILLUM

C
C     Squeeze all blanks out of the aberration correction
C     string; ensure the string is in upper case.
C
      CALL CMPRSS ( ' ', 0, ABCORR, SVCORR )
      CALL UCASE  ( SVCORR,         SVCORR )

C
C     Check the aberration correction. If SPKEZR can't handle it,
C     neither can we.
C
      CALL ZZVALCOR ( SVCORR, SVABLK )

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

C
C     Reject transmission corrections.
C
      IF ( SVABLK(XMTIDX) ) THEN

         CALL SETMSG ( 'Aberration correction was #; '
     .   //            'transmission corrections are not '
     .   //            'allowed by this routine.'        )
         CALL ERRCH  ( '#',  ABCORR                      )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'             )
         CALL CHKOUT ( 'ZZGFILIN'                        )
         RETURN

      END IF

C
C     Look up the radii for the target body.
C
      CALL BODVRD ( TARGET, 'RADII', 3, N, RADII )

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

C
C     Find the surface normal at the surface point. Create a
C     body-fixed state vector for the normal.
C
      CALL SURFNM ( RADII(1), RADII(2), RADII(3), SPOINT, NORMAL )

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

      CALL VEQU ( NORMAL, SVNRML )

C
C     Save the surface point in the body-fixed reference frame.
C
      CALL VEQU ( SPOINT, SVSSPT)

C
C     Save a left-justified, upper case copy of the computation method
C     for the illumination angles.
C
      CALL LJUST ( METHOD, SVMETH )
      CALL UCASE ( SVMETH, SVMETH )

      IF ( SVMETH .NE. 'ELLIPSOID' ) THEN

         CALL SETMSG ( 'The only supported computation method '
     .   //            'is ELLIPSOID; the input method was #.' )
         CALL ERRCH  ( '#',  METHOD                            )
         CALL SIGERR ( 'SPICE(INVALIDMETHOD)'                  )
         CALL CHKOUT ( 'ZZGFILIN'                              )
         RETURN

      END IF

C
C     Save a left-justified, upper case copy of the reference frame
C     name.
C
      CALL LJUST ( FIXREF, SVREF )
      CALL UCASE ( SVREF,  SVREF )

C
C     Look up the frame attributes; make sure the frame is centered
C     on the target body.
C
C
C     Determine the attributes of the frame designated by FIXREF.
C
      CALL NAMFRM ( FIXREF, FXFCDE )

      CALL FRINFO ( FXFCDE, FXCENT, FXCLSS, FXTYID, FOUND )

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

      IF ( .NOT. FOUND ) THEN

         CALL SETMSG ( 'Reference frame # is not recognized by ' //
     .                 'the SPICE frame subsystem. Possibly '    //
     .                 'a required frame definition kernel has ' //
     .                 'not been loaded.'                        )
         CALL ERRCH  ( '#',  FIXREF                              )
         CALL SIGERR ( 'SPICE(UNKNOWNFRAME)'                     )
         CALL CHKOUT ( 'ZZGFILIN'                                )
         RETURN

      END IF

C
C     Make sure that FIXREF is centered at the target body's center.
C
      IF ( FXCENT .NE. SVTARG ) THEN

         CALL SETMSG ( 'Reference frame # is not centered at the '
     .   //            'target body #. The ID code of the frame '
     .   //            'center is #.'                             )
         CALL ERRCH  ( '#',  FIXREF                               )
         CALL ERRCH  ( '#',  TARGET                               )
         CALL ERRINT ( '#',  FXCENT                               )
         CALL SIGERR ( 'SPICE(INVALIDFRAME)'                      )
         CALL CHKOUT ( 'ZZGFILIN'                                 )
         RETURN

      END IF

C
C     Save the index of the angle type.
C
      SVAIDX = ESRCHC ( ANGTYP, 3, ANGNMS )

      IF ( SVAIDX .EQ. 0 ) THEN

         CALL SETMSG ( 'Illumination angle type # is not recognized.' )
         CALL ERRCH  ( '#',  ANGTYP                                   )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                          )
         CALL CHKOUT ( 'ZZGFILIN'                                     )
         RETURN

      END IF

      CALL CHKOUT ( 'ZZGFILIN' )
      RETURN

C$Procedure ZZGFILDC ( GF, is illumination angle decreasing? )

      ENTRY ZZGFILDC ( UDFUNC, ET, DECRES )

C$ Abstract
C
C     Indicate whether a specified illumination angle is decreasing at
C     a specified time.
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     NAIF_IDS
C     SPK
C     TIME
C
C$ Keywords
C
C     ANGLE
C     EPHEMERIS
C     GEOMETRY
C     SEARCH
C
C$ Declarations
C
C     EXTERNAL              UDFUNC
C     DOUBLE PRECISION      ET
C     LOGICAL               DECRES
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     UDFUNC     I   Placeholder external routine argument.
C     ET         I   Ephemeris seconds past J2000 TDB.
C     DECRES     O   Flag indicating whether illumination angle is
C                    decreasing.
C
C$ Detailed_Input
C
C     UDFUNC     is a placeholder subroutine argument. This argument is
C                provided for compatibility with ZZGFSOLVX. It is not
C                used by the entry points of this package.
C
C     ET         is the time, expressed as seconds past J2000 TDB, at
C                which to determine whether or not the illumination
C                angle between the observer and target is decreasing.
C
C$ Detailed_Output
C
C     DECRES     is a logical flag that indicates whether the
C                observer-target illumination angle is decreasing at
C                ET. The observer, target, and aberration correction
C                used to compute the illumination angle are defined by
C                the latest call to the initialization entry point
C                ZZGFILIN.
C
C                DECRES is .TRUE. if and only if the observer-target
C                illumination angle is decreasing at ET.
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the state of the target relative to the observer
C        at ET can not be found due to an SPK lookup failure,
C        the error will be diagnosed by routines in the call
C        tree of this routine.
C
C$ Files
C
C     See the header of the umbrella routine ZZGFILU.
C
C$ Particulars
C
C     This routine is used by ZZGFRELX, and indirectly by GFILUM, to
C     determine the time intervals, within the confinement window, on
C     which the observer-target illumination angle is monotone
C     increasing or monotone decreasing.
C
C$ Examples
C
C     See GFILUM, GFEVNT, ZZGFRELX.
C
C$ Restrictions
C
C     This is a SPICELIB private routine; it should not be called by
C     user applications.
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.1.0 08-MAR-2017 (NJB)
C
C        Bug fix: now checks FAILED after ZZILUSTA call.
C
C-    SPICELIB Version 1.0.0 23-MAY-2012 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     indicate whether illumination angle is decreasing
C
C-&

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

      CALL CHKIN ( 'ZZGFILDC' )

C
C     Compute the rates of change of all of the illumination angles.
C
      CALL ZZILUSTA ( SVMETH, SVTNAM, SVINAM, ET,
     .                SVREF,  SVCORR, SVONAM, SVSSPT,
     .                SVNRML, PHSSTA, INCSTA, EMISTA  )

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

      IF ( SVAIDX .EQ. PHSIDX ) THEN

         RATE = PHSSTA(2)

      ELSE IF ( SVAIDX .EQ. INCIDX ) THEN

         RATE = INCSTA(2)

      ELSE IF ( SVAIDX .EQ. EMTIDX ) THEN

         RATE = EMISTA(2)

      ELSE
C
C        We should never get here.
C
         CALL SETMSG ( 'Unexpected value of SVAIDX: #.' )
         CALL ERRINT ( '#',  SVAIDX                     )
         CALL SIGERR ( 'SPICE(BUG)'                     )

      END IF
C
C     The observer-target illumination angle is decreasing if and only
C     the derivative of the angle with respect to time is negative.
C
      DECRES  =  RATE  .LT.  0.D0

      CALL CHKOUT ( 'ZZGFILDC' )
      RETURN

C$Procedure ZZGFILGQ ( GF, get illumination angle )

      ENTRY ZZGFILGQ ( ET, ANGLE )

C$ Abstract
C
C     Return the specified illumination angle at a specified epoch.
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     NAIF_IDS
C     SPK
C     TIME
C
C$ Keywords
C
C     ILLUMINATION ANGLE
C     EPHEMERIS
C     GEOMETRY
C     SEARCH
C
C$ Declarations
C
C      DOUBLE PRECISION      ET
C      DOUBLE PRECISION      ANGLE
C
C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     ET         I   Ephemeris seconds past J2000 TDB.
C     ANGLE      O   Illumination angle at time ET.
C
C$ Detailed_Input
C
C     ET         is the time, expressed as seconds past J2000 TDB, at
C                which the illumination angle is to be computed.
C
C$ Detailed_Output
C
C     ANGLE      is the illumination angle as seen by the observer at
C                time ET. The observer, target, and aberration
C                correction used to compute the illumination angle are
C                defined by the latest call to the initialization entry
C                point ZZGFILIN.
C
C                Units are radians.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the position of the target relative to the observer
C        at ET can not be found due to an SPK lookup failure,
C        the error will be diagnosed by routines in the call
C        tree of this routine.
C
C$ Files
C
C     See the header of the umbrella routine ZZGFILU.
C
C$ Particulars
C
C     This routine determines the apparent illumination angle as seen
C     from the observer at time ET. This functionality supports GFREL's
C     comparisons of relative extrema in order to determine absolute
C     extrema.
C
C$ Examples
C
C     See GFREL.
C
C$ Restrictions
C
C     This is a SPICELIB private routine; it should not be called by
C     user applications.
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.1.0 08-MAR-2017 (NJB)
C
C        Bug fix: now checks FAILED after ILLUMG call.
C
C-    SPICELIB version 1.0.0 23-MAY-2012 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     return illumination angle
C
C-&

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZGFILGQ' )

      CALL ILLUMG ( SVMETH, SVTNAM,    SVINAM,    ET,      SVREF,
     .              SVCORR, SVONAM,    SVSSPT,    ETTARG,
     .              SRFVEC, ANGLES(1), ANGLES(2), ANGLES(3)       )

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

      ANGLE = ANGLES( SVAIDX )

      CALL CHKOUT ( 'ZZGFILGQ' )
      RETURN
      END


      subroutine rexsph ( mphase, ipr2, ispec, vixan, xkstep, xkmax,
     1             gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

      use json_module
      implicit double precision (a-h, o-z)
      logical :: found
      type(json_file) :: json   !the JSON structure read from the file:
      double precision toss
      integer,dimension(:),allocatable :: intgs
      character*80,dimension(:),allocatable :: strings
      double precision,dimension(:),allocatable :: dbpcs

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'

cc    geom.dat
      integer  nat, iatph(0:nphx), iphat(natx), ibounc(natx)
      double precision  rat(3,natx)
cc    global.dat
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod2.inp
        integer mphase, ipr2, ixc, ixc0, ispec, lreal, lfms2, l2lp, iPl,
     &       iGrid
        double precision rgrd, gamach, xkstep, xkmax, vixan
        double precision vr0, vi0, spinph(0:nphx)
        real rfms2
        integer lmaxph(0:nphx)
        character*6  potlbl(0:nphx)
        integer izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis

c     Local stuff
c      character*512 slog
c      character*80 head(nheadx)
c      dimension lhead(nheadx)

c     standard formats for string, integers and real numbers
c  10  format(a)
c  20  format (20i4)
c  30  format (6f13.5)

      call json_read_geom(nat, nph, iatph, rat, iphat, ibounc)

      call json_read_global(nabs, iphabs, rclabs, ipol, ispin, le2,
     1                      elpty, angks, evec, xivec, spvec, ptz)

      call json%load_file('xsph.json')
      if (json_failed()) then   !if there was an error reading the file
         print *, "failed to read xsph.json"
         stop
      else
         call json%get('mphase',   mphase, found)
                   if (.not. found) call bailout('mphase', 'xsph.json')
         call json%get('ipr2',   ipr2, found)
                   if (.not. found) call bailout('ipr2', 'xsph.json')
         call json%get('ixc',   ixc, found)
                   if (.not. found) call bailout('ixc', 'xsph.json')
         call json%get('ixc0',   ixc0, found)
                   if (.not. found) call bailout('ixc0', 'xsph.json')
         call json%get('ispec',   ispec, found)
                   if (.not. found) call bailout('ispec', 'xsph.json')
         call json%get('lreal',   lreal, found)
                   if (.not. found) call bailout('lreal', 'xsph.json')
         call json%get('lfms2',   lfms2, found)
                   if (.not. found) call bailout('lfms2', 'xsph.json')
         call json%get('nph',   nph, found)
                   if (.not. found) call bailout('nph', 'xsph.json')
         call json%get('l2lp',   l2lp, found)
                   if (.not. found) call bailout('l2lp', 'xsph.json')
         call json%get('iPlsmn', iPl, found)
                   if (.not. found) call bailout('iPlsmn', 'xsph.json')
         call json%get('iGrid',   iGrid, found)
                   if (.not. found) call bailout('iGrid', 'xsph.json')

         call json%get('vro',   vr0, found)
                   if (.not. found) call bailout('vr0', 'xsph.json')
         call json%get('vio',   vi0, found)
                   if (.not. found) call bailout('vi0', 'xsph.json')

         call json%get('rgrd',   rgrd, found)
                   if (.not. found) call bailout('rgrd', 'xsph.json')
         call json%get('rfms2',  toss, found)
                   if (.not. found) call bailout('rfms2', 'xsph.json')
         rfms2 = real(toss)
         call json%get('gamach',   gamach, found)
                   if (.not. found) call bailout('gamach', 'xsph.json')
         call json%get('xkstep',   xkstep, found)
                   if (.not. found) call bailout('xkstep', 'xsph.json')
         call json%get('xkmax',   xkmax, found)
                   if (.not. found) call bailout('xkmax', 'xsph.json')
         call json%get('vixan',   vixan, found)
                   if (.not. found) call bailout('vixan', 'xsph.json')

         call json%get('izstd',   izstd, found)
                   if (.not. found) call bailout('izstd', 'xsph.json')
         call json%get('ifxc',   ifxc, found)
                   if (.not. found) call bailout('ifxc', 'xsph.json')
         call json%get('ipmbse',   ipmbse, found)
                   if (.not. found) call bailout('ipmbse', 'xsph.json')
         call json%get('itdlda',   itdlda, found)
                   if (.not. found) call bailout('itdlda', 'xsph.json')
         call json%get('nonlocal',   nonlocal, found)
                if (.not. found) call bailout('nonlocal', 'xsph.json')
         call json%get('ibasis',   ibasis, found)
                   if (.not. found) call bailout('ibasis', 'xsph.json')

         call json%get('potlbl', strings, found)
                   if (.not. found) call bailout('potlbl', 'xsph.json')
         do itit = 1, nphx
c            potlbl(itit-1) = strings(itit)
            potlbl(itit-1) = strings(itit)(1:6)
         enddo
         call json%get('lmaxph', intgs, found)
                   if (.not. found) call bailout('lmaxph', 'xsph.json')
         do iph = 0, nphx
            lmaxph(iph) = intgs(iph+1)
         enddo
         call json%get('spinph', dbpcs, found)
                   if (.not. found) call bailout('spinph', 'xsph.json')
         do iph = 0, nphx
            spinph(iph) = dbpcs(iph+1)
         enddo

         call json%destroy()
      end if

c     transform to code units (bohrs and hartrees - atomic unuts)
      rfms2 = rfms2 / real(bohr)
      vr0   = vr0 / hart
      vi0   = vi0 / hart
      gamach = gamach / hart
      vixan = vixan / hart
      xkstep = xkstep * bohr
      xkmax  = xkmax  * bohr
      do i = 1,3
         do iat = 1, nat
            rat(i,iat) = rat(i,iat) / bohr
         enddo
      enddo

      return
      end


      SUBROUTINE maxiex( buf, ibuf, lbuf, istop )
c     MicroMAX disk file input.
c     Among the problems with this format are:
c  1)  I don't know what type of machine wrote the data.  I'm going to
c  assume that it was an IEEE machine.  I'll also assume that the machine
c  we're running on is IEEE.  That leaves big endian vs. little endian.
c  Both for the machine that created the data as well as the machine we're
c  running this on.  We need to swap bytes if they are different.  e.g.
c  if the data was created on a Compaq and sioseis is running on a Sun, we
c  need to byte swap.  Word 49 of header 1 (.hd1) is the number of data
c  channels actually written to the disk file.  If this is negative or
c  greater than 2**16-1, then we need to do a byte swap.
c
c
c  Copyright (C) 1992 Seismic Reflection Processors, Solana Beach, CA.
c  ALL RIGHTS RESERVED.
c
      INTEGER ultrix, vms, sun
      PARAMETER ( ULTRIX = 2 )
      PARAMETER ( VMS = 4 )
      PARAMETER ( SUN = 7 )
      DIMENSION buf(111), lbuf(111), ibuf(111)
      DIMENSION vax(80)
      INTEGER*2 ibuf
      INTEGER cdpno, cdptrno
      COMMON /edits/ ierror, iwarn, irun, now, icompt
      COMMON /readt/ itunit, numhdr, nsamps, ihunit, ireeln, jntrcs
      COMMON /maxin/ luni, lunhd1, lunhd2, fno, lno, noinc, ftr, ltr,
     &       trinc, lprint
      LOGICAL first, swap
      SAVE
      DATA first/.TRUE./, swap/.FALSE./, cdpno/0/, cdptrno/0/
      DATA ntraces/0/, nhdr1/52/
c
      IF( first ) THEN
          first = .FALSE.
          CALL podisc( lun1, 1, 0 )                                     ! rewind all the files
          CALL podisc( lunhd1, 1, 0 )
          CALL podisc( lunhd2, 1, 0 )
          CALL rddisc( lunhd1, buf, nhdr1, istat )
          IF( icompt .EQ. SUN ) CALL swap32( buf, 52 )
          IF( icompt .EQ. VMS ) CALL pc2dr( buf(8), 1, buf(8) )
          ntrace = lbuf(1)
          si = buf(8) / 1000.
          nsamps = lbuf(9)
          icdpsrt = lbuf(47)                                            ! 0 = not sorted, 1 = sorted
          jntrcs = lbuf(49)
          iftype = lbuf(52)
          IF( IAND(lprint,1) .NE. 0 ) PRINT *,' si =',si,' nsamps=',
     &        nsamps ,' icdpsrt = ',icdpsrt,' jntrcs =',jntrcs,
     &        ' iftype = ',iftype
      ENDIF
  100 CALL rddisc( lunhd2, buf, 80, istat )
      IF( istat .NE. 80 ) THEN
          istop = -1
          RETURN
      ENDIF
      IF( icompt .EQ. SUN ) CALL swap32( buf, 80 )
      IF( icompt .EQ. VMS ) THEN
          DO 110, i = 1, 80
  110     vax(i) = buf(i)
          CALL pc2dr( vax, 80, vax )
          buf(6) = vax(6)
          buf(9) = vax(9)
          DO 120, i = 15, 46
  120     buf(i) = vax(i)
          buf(48) = vax(48)
          buf(49) = vax(49)
          buf(50) = vax(50)
          buf(57) = vax(57)
      ENDIF
      istrac = lbuf(1)
      ishot = lbuf(2)
      irecvr = lbuf(3)
      iscdp = lbuf(4)
      ischan = lbuf(5)
      offset = buf(6)
      idxtype = lbuf(7)
      iffid = lbuf(8)
      samrat = buf(9)
      nsamps = lbuf(10)
      nmute = lbuf(11)
      nmute2 = lbuf(12)
      ixcor = lbuf(13)
      iycor = lbuf(14)
      tstat = buf(15)
      tstogo = buf(16)
      tdatum = buf(17)
      tcdp = buf(18)
      anorml = buf(19)
      xtrces = buf(20)
      xsum = buf(21)
      ysum = buf(22)
      cdpxsavg = buf(23)
      fold = buf(24)
      fbxpick = buf(25)
      uhxtime = buf(26)
      elvxsrc = buf(27)
      elvxgrp = buf(28)
      zxhole = buf(29)
      cdpgrp = buf(30)
      fxbamp = buf(31)
      prefbxamp = buf(32)
      trcxamp = buf(33)
      grpxnum = buf(34)
      srcxnum = buf(35)
      jxgrpx = buf(36)
      jygrpx = buf(37)
      jxsrcx = buf(38)
      jysrcx = buf(39)
      dstos = buf(40)
      statrx = buf(41)
      statsx = buf(42)
      rstrx = buf(43)
      rstsx = buf(44)
      rfstrx = buf(45)
      rfstsx = buf(46)
      itrcdp = lbuf(47)
      tmultiplx = buf(48)
      uhxgrp = buf(49)
      v1grpx = buf(50)
      ixyear = lbuf(51)
      ixday = lbuf(52)
      ixhour = lbuf(53)
      ixmin = lbuf(54)
      ixsec = lbuf(55)
      ixrtype = lbuf(56)
      wgtcdp = buf(57)
      IF( IAND(lprint,2) .NE. 0 ) THEN
          PRINT *,(lbuf(i),i=1,5)
          PRINT *,buf(6),(lbuf(i),i=7,8),buf(9),lbuf(10)
          PRINT *,(lbuf(i),i=11,14),buf(15)
          PRINT *,(buf(i),i=16,20)
          PRINT *,(buf(i),i=21,25)
          PRINT *,(buf(i),i=26,30)
          PRINT *,(buf(i),i=31,35)
          PRINT *,(lbuf(i),i=36,39),buf(40)
          PRINT *,(buf(i),i=41,45)
          PRINT *,buf(46),lbuf(47),(buf(i),i=48,50)
          PRINT *,(lbuf(i),i=51,55)
          PRINT *,lbuf(56),buf(57),(lbuf(i),i=58,60)
      ENDIF
c**** count the traces read and set istop if the current trace is the last
      ntraces = ntraces + 1
      IF( ntraces .EQ. ntrace ) istop = 1
c****
c****   We have to count the traces in the rp gather if it's been gathered
c****
      IF( icdpsrt .EQ. 1 ) THEN
          cdptrno = cdptrno + 1
          IF( iscdp .NE. cdpno ) THEN                                   ! is the MicroMAX bin number different?
              cdptrno = 1
          ENDIF
          cdpno = iscdp
      ENDIF
c****
c****   See if it's a shot/rp and trace the user wanted
c****
      IF( icdpsrt .EQ. 0 ) THEN
          IF( ishot .LT. fno ) GOTO 100
          IF( ischan .LT. ftr ) GOTO 100
          IF( lno .NE. 0 .AND. ishot .GT. lno ) GOTO 100
          IF( ltr .NE. 0 .AND. ischan .GT. ltr ) GOTO 100
      ELSE
          IF( iscdp .LT. fno ) GOTO 100
          IF( cdptrno .LT. ftr ) GOTO 100
          IF( lno .NE. 0 .AND. iscdp .GT. lno ) GOTO 100
          IF( ltr .NE. 0 .AND. cdptrno .GT. ltr ) GOTO 100
      ENDIF
c****
c****  set the SEGY trace header
c****
      si = samrat / 1000.
      DO 500 i = 1, numhdr
  500 lbuf(i) = 0
      lbuf(1) = istrac
      lbuf(3) = ishot
      lbuf(4) = ischan                                                  ! original recording channel number
      lbuf(6) = iscdp
      lbuf(7) = cdptrno
      lbuf(10) = NINT(offset)
      lbuf(11) = elvxgrp
      lbuf(12) = elvxsrc
      lbuf(19) = jxsrcx
      lbuf(20) = jysrcx
      lbuf(21) = jxgrpx
      lbuf(22) = jygrpx
      IF( cdptrno .EQ. itrcdp ) lbuf(51) = -1                           ! set the sioseis end of gather flag
      IF( nmute .NE. nsamps + 1 ) THEN
          ibuf(15) = 1
      ELSE
          ibuf(15) = 2
      ENDIF
      ibuf(16) = xtrces
      ibuf(17) = fold
      ibuf(48) = uhxtime
      ibuf(50) = statsx
      ibuf(51) = statrx
      ibuf(52) = tstat
      ibuf(57) = FLOAT(nmute) * si * 1000.
      ibuf(58) = nsamps
      ibuf(59) = samrat * 1000.
      ibuf(79) = ixyear
      ibuf(80) = ixday
      ibuf(81) = ixhour
      ibuf(82) = ixmin
      ibuf(83) = ixsec
      buf(49) = si
      buf(47) = FLOAT(nmute) * si
c****
c****  now get the data
c****
      IF( iftype .EQ. 0 ) THEN                                          ! 0 = 32 bit floating point (whose??)
          CALL rddisc( luni, buf(numhdr+1), nsamps, istat )
          IF( istat .NE. nsamps ) THEN
              istop = -1
              RETURN
          ENDIF
          IF( icompt .EQ. SUN ) CALL swap32( buf(numhdr+1), nsamps )
          IF( icompt .EQ. VMS )
     &        CALL pc2dr( buf(numhdr+1), nsamps, buf(numhdr+1) )
      ELSEIF( iftype .EQ. 1 ) THEN
          IF( icompt .EQ. VMS .AND. nsamps / 2 * 2 .NE. nsamps ) THEN
              PRINT *,' nsamps must be even when using 16 bit integers.'
c             The problem here is that the VMS Vax doesn't have byte disk I/O
              STOP
          ENDIF
          IF( icompt .EQ. VMS ) THEN
              CALL rddisc( luni, buf(numhdr+1), nsamps/2, istat )
              IF( istat .NE. nsamps/2 ) THEN
                  istop = -1
                  RETURN
              ENDIF
          ELSE
              CALL rddiscb( luni, buf(numhdr+1), nsamps*2, istat )
              IF( istat .NE. nsamps*2 ) THEN
                  istop = -1
                  RETURN
              ENDIF
          ENDIF
          IF( icompt .EQ. SUN ) CALL swap16( buf(numhdr+1), nsamps )
          DO 1000, i = 1, nsamps
             buf(numhdr+nsamps-i+1)  = ibuf(numhdr*2+i)
 1000     CONTINUE
      ENDIF

      END


Module declare

   IMPLICIT NONE

   INTEGER(KIND=8)::TIMESTART,TIMERUN,count_rate,cr,jstep,jstart(1000)
   REAL(KIND=8)::LASTTIME,rate

   INTEGER NATOMOLD,NATOM,NATOMNEW,NATOMMAX,NSYN,NSYNMAX,NPG,NPGMAX,NBONDGLY,NGLYMAX,NBONDPEP,NPEPMAX,NLOOP,NLOOPMAX
   INTEGER NPGOLD,NPGNEW,CAPLEN,NCAP,NBONDCAP,NBONDGLYOLD!,CAPBOUND1,CAPBOUND2
   INTEGER SYNRATIO,NATOMCAP,NB1,NB2,JRESET,LENMAX,newlengthave,length
   INTEGER NBOND,NBONDDEL,NBONDGLYSTART,NSIG
   INTEGER NL,NLOOPDEL,NB,PGCAP1,PGCAP2
   INTEGER PGLENMAX,LOOPLENMAX,JLYT,JRECOMP
   INTEGER TIMES(10),YEARS,MONS,DAYS,HOURS,MINS,SECS
   INTEGER N,NTHREADS!,OMP_GET_NUM_THREADS
   INTEGER NSTART,NR,JFORCE1,JFORCE2,SLOWLOAD
   INTEGER NTIP,ntip1,ntip2,NSEC,NPICK,ILOOP,JLINK,NNEW,JRFORCE,NRAND
   INTEGER NS,NS1,NPEPTOTAL,NATOMSTART,NPGSTART,NGLYNEW,ns_ter,jsyndir,na_red
   INTEGER NATOMDEL,OLDNATOMDEL,NDEL,N1,N2,NA,nstore,npress
   INTEGER JR,NTOTAL,JFILE,NFRAME,JL,JS,NTRAP,JCHANGE,JSCALE,A22,JSKIP,SKIP
   INTEGER IPG,JUNIT,NSYNREP,NTRANS,NHOLD,NRELAX,J1,J2,JEXIT,JPRINT,JRANDS,N_EDHOLD,noldbond,jpgnew,noldmax
   integer oldtypmax,jredist,jrestart,jsteric,ipg1,ipg2,jfast1,jfast2,jprevent,joldbond,nnewhoop
   integer pgbelowbondmax,ntemlink,ntemlinkmax,nprint

   INTEGER(kind=8),DIMENSION(:),ALLOCATABLE::jtrap,J_EDHOLD
   INTEGER,DIMENSION(:),ALLOCATABLE:: EDOSIG,TP2SIG,EDCAP,JDEACT,COUPLING
   INTEGER,DIMENSION(:,:),ALLOCATABLE::PGID,newpgid,EDHOLD,SIGBOND,EDPEP,JTERM
   INTEGER,DIMENSION(:,:),ALLOCATABLE::NEWPGIDtemp,TRANSGLY,GLYTIP,GLYSEC,oldglytip,oldglysec,temlink
   INTEGER,DIMENSION(:),ALLOCATABLE::PGLEN,newpglentemp,PGDIR,DNOR,ATOR,PEPDIR,glyid
   INTEGER,DIMENSION(:),ALLOCATABLE::NEWPGLEN,NEWPGTYP,NEWPGDIR,ATORNEW,DNORNEW,PEPDIRNEW
   INTEGER,DIMENSION(:,:),ALLOCATABLE::BOND,BONDGLY,BONDPEP,oldbond
   INTEGER,DIMENSION(:,:),ALLOCATABLE::NEWBONDGLY,NEWBONDPEP,SIGCROSS,ADDSIG
   INTEGER,DIMENSION(:),ALLOCATABLE::BONTYP,oldtyp,pgbelowbond
   INTEGER,DIMENSION(:),ALLOCATABLE::NEWBONTYP,SYNMARK,JR_ENDO_ON,JR_ENDO_OFF,SIGCLEAVE,EDLOCKIN
   INTEGER,DIMENSION(:,:),ALLOCATABLE::LOOP,NEWLOOP,PARTNER
   INTEGER,DIMENSION(:,:),ALLOCATABLE::CRLKAGE,NETWORK,SYNTHESIS,SYNPG
   INTEGER,DIMENSION(:),ALLOCATABLE::LOOPLEN,NEWLOOPLEN,LOOPTYP,NEWLOOPTYP
   INTEGER,DIMENSION(:),ALLOCATABLE:: SYNDIR,SYNLOOP,GTLOAD,GTATRANS
   INTEGER,DIMENSION(:),ALLOCATABLE:: NEINUM,GLYNUM
   INTEGER,DIMENSION(:,:,:),ALLOCATABLE::NEIBOND,NEIGLY,TPPEP

!   INTEGER,DIMENSION(:),ALLOCATABLE:: temlen,temtyp
!   INTEGER,DIMENSION(:,:),ALLOCATABLE::temid
!   integer ntem

   DOUBLE PRECISION PI!= 3.141592653589793239D0
   DOUBLE PRECISION L_G,K_G,L_P,K_P,THETA_0,KTHETA,PRES,P_COUPL,P_UCOUP,MreBlen0
   DOUBLE PRECISION P_ACTI,P_DEACT,PTERM0,pterm,P_GLYIN,P_PEPIN,P_PEPOUT,P_EDHOLD,PCLEAVE_SPON,PEDCAP_SPON,PEDCAP_INACT
   DOUBLE PRECISION PMATURE,PLYT,GROWTH,P_GLYOUT,PBEND,P_TRANSFAST,P_TRANSSLOW,prmbond,wthick,pthick,kaxis
   DOUBLE PRECISION p_trans,lambda

   DOUBLE PRECISION sigma,kmidcell,fmid,fconstrict,pconstrict0!,pconstrict(1000),pconstrictold(1000)
   DOUBLE PRECISION delx,invdelx,dpcons,xpbp,ftotal,lfinal,lcons

   DOUBLE PRECISION XCAP1,XCAP2,R,GAM,FAMAX,DREACT,DREACT2,DIST
   DOUBLE PRECISION FPMAX1,FPMAX2,FPMAX3,FPMAX4,FPMAX5,FPMAX6
   DOUBLE PRECISION DX,DY,DZ,FPBPMAX,INVMPBP,AREA,ORAD
   DOUBLE PRECISION LSTART,LREP,LSWITCH,KSWITCH,MSWITCH
   DOUBLE PRECISION KGTASE,KTPASE,LTPASE,KPAIR,LPAIR,KGTTP,LGTTP13,LGTTP2,l_edcap
   DOUBLE PRECISION KEDASE,LEDASE,KGTED,LGTED,KWALL,KLEAD,DELTA,INVDELTA,BETA,KSUR,KSIDE,LSIDE,ktped,ltped

   real(kind=8)::ratio(1000),newratio

   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE:: X,Y,Z,XEDASEOLD,YEDASEOLD,ZEDASEOLD
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE:: XNEW,YNEW,ZNEW,XLEAD,YLEAD,ZLEAD,XEDASE,YEDASE,ZEDASE
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FX,FY,FZ,FAMAG,FXGLY,FYGLY,FZGLY,FXSUR,FYSUR,FZSUR
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FXPEP,FYPEP,FZPEP,FXTHETA,FYTHETA,FZTHETA
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FXREP,FYREP,FZREP
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FXPRES,FYPRES,FZPRES,FXSYN,FYSYN,FZSYN
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FXCAPBI1,FXCAPBI2,FXCAPMON,FXCAPEDO
   DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE::XGTASE,YGTASE,ZGTASE,FXGTASE,FYGTASE,FZGTASE,LGTASE
   DOUBLE PRECISION,DIMENSION(:,:),ALLOCATABLE::FXTPASE,FYTPASE,FZTPASE,XTPASE,YTPASE,ZTPASE
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::FXEDASE,FYEDASE,FZEDASE,FMAGPBP
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::R1,R2,EDRAD,BIRAD1,BIRAD2,MORAD,RANDS
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::RXGTASE,RYGTASE,RZGTASE,RXTPASE,RYTPASE,RZTPASE
   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE::RXEDASE,RYEDASE,RZEDASE,fycon,fzcon

   DOUBLE PRECISION,DIMENSION(:),ALLOCATABLE:: XCEN,YCEN,ZCEN,UX,UY,UZ,MreBlen,P_CURV,P_UCURV
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:)::YCENBI1,ZCENBI1,YCENBI2,ZCENBI2
   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:)::YCENMON,ZCENMON,YCENEDO,ZCENEDO,randstore

   DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:)::xsyn,pconstrict,pconstrictold

   REAL,DIMENSION(:),ALLOCATABLE::XW,YW,ZW
   character (len=512) command

end module


subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
           obstype,twind,sis,ithin,rmesh,nobs)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    read_ozone                    read ozone data
!   prgmmr: yang             org: np23                date: 1998-05-15
!
! abstract:  This routine reads SBUV/2 ozone observations.  Both layer
!            and total column values are read in.  The routine has
!            the ability to read both IEEE and BUFR format SBUV/2
!            ozone data files. OMI and GOME data is optionally thinned
!            to a specific resolution using simple quality control checks.
!
!            When running the gsi in regional mode, the code only
!            retains those observations that fall within the regional
!            domain
!
! program history log:
!   1998-05-15  yang, weiyu
!   1999-08-24  derber, j., treadon, r., yang, w., first frozen mpp version
!   2004-06-16  treadon - update documentation
!   2004-07-29  treadon - add only to module use, add intent in/out
!   2004-09-17  todling - fixed intent of jsatid
!   2004-12-02  todling - compilation in OSF1 forces big_endian for bufr files;
!                         need to force little_endian for ieee files
!   2004-12-22  kokron  - change cpp tokens to add support for ifort compiler
!                         efc does not have a convert option so it should use
!                         the other 'open'
!   2005-03-14  treadon - define numeric constants to r_kind precision
!   2005-05-12  wu - add OMI total ozone
!   2005-06-27  guo     - bug fix: hour read from header was incorrect
!   2005-09-08  derber - modify to use input group time window
!   2005-09-19  treadon - add check on NOAA-17 sbuv data (toss bad data)
!   2005-10-17  treadon - add grid and earth relative obs location to output file
!   2005-10-18  treadon - remove array obs_load and call to sumload
!   2005-12-23  treadon - bound longitude to be less than 360.0
!   2006-01-26  treadon - remove ieee sbuv option
!   2006-02-03  derber  - modify for new obs control and obs count
!   2007-03-01  tremolet - measure time from beginning of assimilation window
!   2007-07-10  zhou    - modify to read version 8 SBUV/2 BUFR data(keep
!                         option to read version 6 data), also add
!                         total ozone and ozone profile quality control.
!   2007-09-11  h.liu - add kidsat for nimbus-7, n09, n11, n14
!   2007-10-16  zhou    - organize ozone flag control for all satellites
!   2008-04-16  h.liu   - thin OMI and read in GOME data
!   2008-05-27  safford - rm unused vars and uses
!   2008-05-30  treadon - accept  version8 poq=7 obs for further processing
!   2008-06-01  treadon - adjust logic to correctly handle zero length BUFR files
!   2008-06-03  treadon - add use_poq7 flag
!   2008-09-08  lueken  - merged ed's changes into q1fy09 code
!   2009-01-20  sienkiewicz - merge in changes for MLS ozone
!   2009-04-21  derber  - add ithin to call to makegrids
!   2009-3-05   h.liu   - read in OMI bufr, QC GOME2 and OMI
!   2009-7-02   h.liu   - toss the OMI data with AFBO=3 (c-pair correction) and clean up codes
!   2010-05-26  treadon - add timedif=zero for l4dvar (used in thinning)
!   2010-06-02  sienkiewicz - care for closing bufr other than for o3lev
!   2011-07-04  todling  - fixes to run either single or double precision
!   2011-08-01  lueken  - replaced F90 with f90 (no machine logic)
!   2012-10-12  h.liu  - read in MLS v2 Near Real Time (NRT) and v2.2 standard bufr data
!   2013-01-17  h.liu  - read in MLS v3 Near Real Time (NRT)
!   2013-01-26  parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS)
!   2014-02-03  guo	- removed unused "o3lev" handling, which can (and should) be
!                         implemented again in module m_extOzone, if ever needed.
!   2015-02-23  Rancic/Thomas - add thin4d to time window logical
!   2015-10-01  guo     - consolidate use of ob location (in deg
!   2017-12-05  wargan  - implement OMPS nadir capability
!   2018-05-21  j.jin   - added time-thinning. Moved the checking of thin4d into satthin.F90.
!   2018-06-26  todling - total column nadir OMPS of Wargan and Liu handling redundant NM/TC8 names
!   2018-08-13  H. Liu  - add capability to use OMPS nadir profiler and nadir mapper data
!
!   input argument list:
!     obstype  - observation type to process
!     jsatid   - satellite id to read
!     infile   - unit from which to read ozone data
!     gstime   - analysis time in minutes from reference date
!     lunout   - unit to which to write data for further processing
!     obstype  - observation type to process
!     twind    - input group time window (hours)
!     sis      - satellite/instrument/sensor indicator
!     ithin    - flag to thin data
!     rmesh    - thinning mesh size (km)
!
!   output argument list:
!     nread    - number of sbuv/omi ozone observations read
!     ndata    - number of sbuv/omi ozone profiles retained for further processing
!     nodata   - number of sbuv/omi ozone observations retained for further processing
!     nobs     - array of observations on each subdomain for each processor
!
! remarks:
!   NCEP stopped producing IEEE format sbuv ozone files in April 2004.
!   Hence, the IEEE portion of this routine no future application.  It
!   is retained in the GSI package for use with retrospective runs.  The
!   IEEE portion of this routine may be removed from the GSI at a later date.
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds, only: r_kind,r_double,i_kind
  use satthin, only: makegrids,map2tgrid,destroygrids, &
      finalcheck,itxmax
  use satthin, only: radthin_time_info,tdiff2crit
  use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons
  use constants, only: deg2rad,zero,one_tenth,r60inv,two
  use obsmod, only: nloz_v6,nloz_v8
  use obsmod, only: time_window_max
  use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen
  use radinfo, only: dec2bin
  use qcmod, only: use_poq7
  use ozinfo, only: jpch_oz,nusis_oz,iuse_oz
  use mpimod, only: npe
  implicit none

! Declare passed variables
  character(len=*),intent(in   ) :: obstype,infile,jsatid
  character(len=20),intent(in  ) :: sis
  integer(i_kind) ,intent(in   ) :: lunout,ithin
  integer(i_kind) ,intent(inout) :: nread
  integer(i_kind),dimension(npe) ,intent(inout) :: nobs
  integer(i_kind) ,intent(inout) :: ndata,nodata
  real(r_kind)    ,intent(in   ) :: gstime,twind,rmesh

! Declare local parameters
  real(r_kind),parameter:: r6   = 6.0_r_kind
  real(r_kind),parameter:: r76  = 76.0_r_kind
  real(r_kind),parameter:: r84  = 84.0_r_kind

  real(r_kind),parameter:: r360 = 360.0_r_kind
  real(r_kind),parameter:: rmiss = -9999.9_r_kind
  real(r_kind),parameter:: badoz = 10000.0_r_kind

! Declare local variables
  logical outside,version6,version8,iuse

  character(2) version
  character(8) subset,subset6,subset8,subset8_ompsnp
  character(49) ozstr,ozostr
  character(63) lozstr
  character(51) ozgstr
  character(27) ozgstr2
  character(42) ozostr2
  character(64) mlstr
  character(14) mlstrl

  integer(i_kind) maxobs,nozdat,nloz
  integer(i_kind) idate,jdate,ksatid,kk,iy,iret,im,ihh,idd,lunin
  integer(i_kind) nmind,i
  integer(i_kind) nmrecs,k,ilat,ilon,nreal,nchanl
! integer(i_kind) ithin,kidsat
  integer(i_kind) kidsat
  integer(i_kind) idate5(5)
  integer(i_kind) JULIAN,IDAYYR,IDAYWK
  integer(i_kind) ikx
  integer(i_kind) decimal,binary(14),binary_mls(18)

  integer(i_kind) itx,itt,ipoq7

  real(r_kind) tdiff,sstime,dlon,dlat,t4dv,crit1,dist1
  real(r_kind) slons0,slats0,rsat,solzen,solzenp,dlat_earth,dlon_earth
  real(r_kind) dlat_earth_deg,dlon_earth_deg
  real(r_kind),allocatable,dimension(:):: poz

! maximum number of observations set to
  real(r_kind),allocatable,dimension(:,:):: ozout
  real(r_double) toq,poq
  real(r_double),dimension(nloz_v6):: ozone_v6
  real(r_double),dimension(29,nloz_v8):: ozone_v8
  real(r_double),dimension(10):: hdroz
  real(r_double),dimension(10):: hdrozg
  real(r_double),dimension(5):: hdrozg2
  real(r_double),dimension(10):: hdrozo
  real(r_double),dimension(8) :: hdrozo2
  real(r_double),dimension(13):: hdrmls
  real(r_double),allocatable,dimension(:,:) :: hdrmlsl
  real(r_kind),allocatable,dimension(:):: mlspres,mlsoz,mlsozpc,usage1
  integer(i_kind),allocatable,dimension(:):: ipos

  real(r_double) totoz,hdrmls13
  integer(i_kind) :: k0
  logical :: first,read_success

! MLS data version: mlsv=22 is version 2.2 standard data;
!                   mlsv=20 is v2 near-real-time data
!                   mlsv=30 is v3 near-real-time data
  integer(i_kind) :: mlsv

  data lozstr &
       / 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' /
  data ozgstr &
       / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' /
  data ozgstr2 &
       / 'CLDMNT SNOC ACIDX STKO FOVN' /
  data ozostr &
       / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA' /
! since 2009020412, the omi bufr contains fovn
  data ozostr2 &
       / 'CLDMNT ACIDX STKO VZAN TOQC TOQF FOVN AFBO' /

  data mlstr &
       / 'SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA CONV MLST PCCF' /
  data mlstrl &
       / 'PRLC OZMX OZMP' /

  data lunin / 10 /
  data subset6 / 'NC008010' /
  data subset8 / 'NC008011' /
  data subset8_ompsnp / 'NC008017'/
  real(r_kind)    :: ptime,timeinflat,crit0
  integer(i_kind) :: ithin_time,n_tbin,it_mesh

!**************************************************************************
! Set constants.  Initialize variables
  rsat=999._r_kind
  maxobs=1e6
  ilon=3
  ilat=4
  ipoq7=0
  if (use_poq7) ipoq7=7

! Separately process sbuv or omi ozone

  if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then

     nreal=9
     open(lunin,file=trim(infile),form='unformatted')
     nmrecs=0
     call openbf(lunin,'IN',lunin)
     call datelen(10)
     call readmg(lunin,subset,idate,iret)

     version6 = .false.
     version8 = .false.
     if (subset == subset6) then
        version6 = .true.
        nloz     = nloz_v6
        version  = 'v6'
     elseif (subset == subset8 .or. subset == subset8_ompsnp) then ! OMPS-NP processed with V8 algorithm
        version8 = .true.
        nloz     = nloz_v8
        version  = 'v8'
     else
        write(6,*)'READ_OZONE:  *** WARNING: unknown layer ozone version type, subset=',subset
        write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid
        write(6,*)' SKIP PROCESSING OF THIS OZONE LAYER FILE'
        call closbf(lunin)
        close(lunin)
        return
     endif

!    Set dependent variables and allocate arrays
     nchanl=nloz+1
     nozdat=nreal+nchanl
     allocate (ozout(nozdat,maxobs))
     allocate (  poz(nloz+1))

!    Set BUFR string based on sbuv version
     if (version6) then
        ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU OSZA OPSZ'
     else if (version8) then
        ozstr='SAID CLAT CLON YEAR MNTH DAYS HOUR MINU SECO SOZA'
     endif

     read_loop1: do
        call readsb(lunin,iret)
        if (iret/=0) then
           call readmg(lunin,subset,jdate,iret)
           if (iret/=0) exit read_loop1
           cycle read_loop1
        endif

!    extract header information
!    BUFR code values for satellite identifiers are listed in
!    Dennis Keyser's website,
!    http://www.emc.ncep.noaa.gov/mmb/papers/keyser/Satellite_Historical.txt

        call ufbint(lunin,hdroz,10,1,iret,ozstr)
        rsat = hdroz(1); ksatid=rsat
        if(jsatid == 'nim07') kidsat = 767
        if(jsatid == 'n09') kidsat = 201
        if(jsatid == 'n11') kidsat = 203
        if(jsatid == 'n14') kidsat = 205
        if(jsatid == 'n16') kidsat = 207
        if(jsatid == 'n17') kidsat = 208
        if(jsatid == 'n18') kidsat = 209
        if(jsatid == 'n19') kidsat = 223
        if(jsatid == 'npp') kidsat = 224
        if(jsatid == 'n20') kidsat = 225
        if(jsatid == 'n21') kidsat = 226

        if (ksatid /= kidsat) cycle read_loop1

        nmrecs=nmrecs+nloz+1

!       Convert observation location to radians
        slats0= hdroz(2)
        slons0= hdroz(3)
        if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop1
        if(slons0< zero) slons0=slons0+r360
        if(slons0==r360) slons0=zero
        dlat_earth_deg = slats0
        dlon_earth_deg = slons0
        dlat_earth = slats0 * deg2rad
        dlon_earth = slons0 * deg2rad

        if(regional)then
           call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
           if(outside) cycle read_loop1
        else
           dlat = dlat_earth
           dlon = dlon_earth
           call grdcrd1(dlat,rlats,nlat,1)
           call grdcrd1(dlon,rlons,nlon,1)
        endif

!    Special check for NOAA-17 version 6
!    Before July 2007 NOAA-17 SBUV/2 has a stray light problem which produces
!    erroneous ozone profile retrievals for a limited portion
!    of its measurements. The contaminated signals only occur
!    in the Southern Hemisphere and only for Solar Zenith
!    Angles (SZA) greater than 76 Degrees.

        if (version6) then
           solzen = hdroz(9)    ! solar zenith angle
           solzenp= hdroz(10)   ! profile solar zenith angle
           if (ksatid==208 .and. dlat_earth<zero .and. solzenp > r76) cycle read_loop1
        else if(version8)then
           solzen = hdroz(10)    ! solar zenith angle
        endif

!       Convert observation time to relative time
        idate5(1) = hdroz(4)  !year
        idate5(2) = hdroz(5)  !month
        idate5(3) = hdroz(6)  !day
        idate5(4) = hdroz(7)  !hour
        idate5(5) = hdroz(8)  !minute
        call w3fs21(idate5,nmind)
        t4dv=real((nmind-iwinbgn),r_kind)*r60inv
        sstime=real(nmind,r_kind)
        tdiff=(sstime-gstime)*r60inv
        if (l4dvar.or.l4densvar) then
           if(t4dv<zero .OR. t4dv>winlen) cycle read_loop1
        else
           if(abs(tdiff) > twind) cycle read_loop1
        end if

!       Extract layer ozone values and compute profile total ozone
        if (version8) then
           call ufbseq(lunin,ozone_v8,29,21,iret,'OZOPQLSQ')
           totoz=zero
           do k=1,nloz
              kk=nloz-k+1
              poz(k) = ozone_v8(6,kk)
              totoz=totoz+ozone_v8(6,k)
           end do
           poz(nloz+1) = totoz
        endif

        if (version6) then
           call ufbint(lunin,ozone_v6,nloz,1,iret,lozstr)
           do k=1,nloz
              kk=nloz-k+1
              poz(k) = ozone_v6(kk)
           end do

!          extract total ozone
           call ufbint(lunin,totoz,1,1,iret,'OTSP')
           poz(nloz+1) = totoz
        endif

!    Extract and apply version 8 total and profile ozone quaility information
!    Toss observations for which the total ozone error code is neither 0 nor 2
!    Toss observations for which the profile ozone error code is neither 0 nor 1
!    NOTES:
!      1) Profile ozone error code 0 identifies good data; 1 identifies good
!         data with a solar zenith angle > 84 degrees;  7 identifies profile
!         for which stray light correction applied
!      2) Total ozone error code 0 indentifies good data; 2 identifies good
!         data with a solar zenith angle > 84 degrees.
!      3) We do not use the version 6 error flags.   Thus, initialize toq and
!         poq to 0 (use the data)

        toq=0._r_double
        poq=0._r_double
        if (version8) then
           call ufbint(lunin,toq,1,1,iret,'SBUVTOQ')
           call ufbint(lunin,poq,1,1,iret,'SBUVPOQ')
           if (toq/=0 .and. toq/=2) cycle read_loop1
           if (poq/=0 .and. poq/=1 .and. poq/=ipoq7) cycle read_loop1
        endif

!       Check ozone layer values.  If any layer value is bad, toss entire profile
        do k=1,nloz
           if (poz(k)>badoz) cycle read_loop1
        end do

!       Write ozone record to output file
        ndata=min(ndata+1,maxobs)
        nodata=nodata+nloz+1
        ozout(1,ndata)=rsat
        ozout(2,ndata)=t4dv
        ozout(3,ndata)=dlon               ! grid relative longitude
        ozout(4,ndata)=dlat               ! grid relative latitude
        ozout(5,ndata)=dlon_earth_deg     ! earth relative longitude (degrees)
        ozout(6,ndata)=dlat_earth_deg     ! earth relative latitude (degrees)
        ozout(7,ndata)=toq                ! total ozone error flag
        ozout(8,ndata)=poq                ! profile ozone error flag
        ozout(9,ndata)=solzen             ! solar zenith angle
        do k=1,nloz+1
           ozout(k+9,ndata)=poz(k)
        end do

!       Loop back to read next profile
     end do read_loop1

!    End of bufr ozone block

! Process GOME-2 data

  else if ( obstype == 'gome') then

     call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time)
     if( ptime > 0.0_r_kind) then
        n_tbin=nint(2*time_window_max/ptime)
     else
        n_tbin=1
     endif

     open(lunin,file=trim(infile),form='unformatted')
     nmrecs=0
     call openbf(lunin,'IN',lunin)
     call datelen(10)
     call readmg(lunin,subset,idate,iret)

     if (subset == 'NC008012') then
        write(6,*)'READ_OZONE:  GOME-2 data type, subset=',subset
     else
        write(6,*)'READ_OZONE:  *** WARNING: unknown ozone data type, subset=',subset
        write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid
        call closbf(lunin)
        close(lunin)
        return
     endif

!    Make thinning grids
     call makegrids(rmesh,ithin,n_tbin=n_tbin)

!    Set dependent variables and allocate arrays
     nreal=14
     nloz=0
     nchanl=1
     nozdat=nreal+nchanl
     allocate (ozout(nozdat,itxmax))
     do k=1,itxmax
        do i=1,nozdat
           ozout(i,k)=rmiss
        end do
     end do

     iy=0
     idd=0
     ihh=0

     obsloop: do
        call readsb(lunin,iret)
        if (iret/=0) then
           call readmg(lunin,subset,jdate,iret)
           if (iret/=0) exit obsloop
           cycle obsloop
        endif

!       extract header information
        call ufbint(lunin,hdrozg,10,1,iret,ozgstr)
        call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2)
        rsat = hdrozg(1); ksatid=rsat

        if(jsatid == 'metop-a')kidsat = 4
        if(jsatid == 'metop-b')kidsat = 3
        if(jsatid == 'metop-c')kidsat = 5

        if (ksatid /= kidsat) cycle obsloop

!       NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree)
        if ( hdrozg(9) > r84 ) cycle obsloop

        nmrecs=nmrecs+nloz+1

!       Convert observation location to radians
        slats0= hdrozg(2)
        slons0= hdrozg(3)
        if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle obsloop
        if(slons0< zero) slons0=slons0+r360
        if(slons0==r360) slons0=zero
        dlat_earth_deg = slats0
        dlon_earth_deg = slons0
        dlat_earth = slats0 * deg2rad
        dlon_earth = slons0 * deg2rad

        if(regional)then
           call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
           if(outside) cycle obsloop
        else
           dlat = dlat_earth
           dlon = dlon_earth
           call grdcrd1(dlat,rlats,nlat,1)
           call grdcrd1(dlon,rlons,nlon,1)
        endif

!       Convert observation time to relative time
        idate5(1) = hdrozg(4)  !year
        IDAYYR = hdrozg(5)     ! Day of year
        JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 &
                 -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR
        call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR)
!       idate5(2) month
!       idate5(3) day
        idate5(4) = hdrozg(6)  !hour
        idate5(5) = hdrozg(7)  !minute
        call w3fs21(idate5,nmind)
        t4dv=real((nmind-iwinbgn),r_kind)*r60inv
        sstime=real(nmind,r_kind)
        tdiff=(sstime-gstime)*r60inv
        if (l4dvar.or.l4densvar) then
           if(t4dv<zero .OR. t4dv>winlen) cycle obsloop
        else
           if(abs(tdiff) > twind) cycle obsloop
        end if

!       extract total ozone
        call ufbint(lunin,totoz,1,1,iret,'OZON')

        if (totoz > badoz ) cycle obsloop

!       only accept flag 0 (good) data
        toq=0._r_double
        call ufbint(lunin,toq,1,1,iret,'GOMEEF')
        if (toq/=0) cycle obsloop

!       only accept scan positions from 2 to 25
        if( hdrozg2(5) < two .or. hdrozg2(5) > 25.0_r_kind ) cycle obsloop

!       thin GOME data
!       GOME data has bias when the satellite looks to the east. Consider QC out this data.

        crit0 = 0.01_r_kind
        timeinflat=r6
        call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
        call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
        if(.not. iuse) cycle obsloop

        call finalcheck(dist1,crit1,itx,iuse)
        if(.not. iuse) cycle obsloop

        ndata=ndata+1
        nodata=ndata

        ozout(1,itx)=rsat
        ozout(2,itx)=t4dv
        ozout(3,itx)=dlon               ! grid relative longitude
        ozout(4,itx)=dlat               ! grid relative latitude
        ozout(5,itx)=dlon_earth_deg     ! earth relative longitude (degrees)
        ozout(6,itx)=dlat_earth_deg     ! earth relative latitude (degrees)
        ozout(7,itx)=toq                ! total ozone error flag
        ozout(8,itx)=hdrozg(9)          ! solar zenith angle
        ozout(9,itx)=hdrozg(10)         ! solar azimuth angle
        ozout(10,itx)=hdrozg2(1)        ! CLOUD AMOUNT IN SEGMENT
        ozout(11,itx)=hdrozg2(2)        ! SNOW COVER
        ozout(12,itx)=hdrozg2(3)        ! AEROSOL CONTAMINATION INDEX
        ozout(13,itx)=hdrozg2(4)        ! ASCENDING/DESCENDING ORBIT QUALIFIER
        ozout(14,itx)=hdrozg2(5)        ! scan position (fovn)
        ozout(15,itx)=totoz

     end do obsloop

!    End of GOME bufr block

! Process OMI/OMPS data without efficiency factors
  else if ( obstype == 'omi' .or. obstype == 'ompsnm' .or. obstype == 'ompstc8') then

     call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time)
     if( ptime > 0.0_r_kind) then
        n_tbin=nint(2*time_window_max/ptime)
     else
        n_tbin=1
     endif

     nmrecs=0
     open(lunin,file=trim(infile),form='unformatted')
     call openbf(lunin,'IN',lunin)
     call datelen(10)
     call readmg(lunin,subset,idate,iret)

     select case(subset)
     case('NC008013')
        write(6,*)'READ_OZONE:  OMI data type, subset=',subset
     case('NC008018')
        write(6,*)'READ_OZONE:  OMPS Nadir Mapper data type, subset=',subset
     case default
        write(6,*)'READ_OZONE:  *** WARNING: unknown ozone data type, subset=',subset
        write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid
        call closbf(lunin)
        close(lunin)
        return
     end select

!    Make thinning grids
     call makegrids(rmesh,ithin,n_tbin=n_tbin)

!    Set dependent variables and allocate arrays
     nreal=14
     nloz=0
     nchanl=1
     nozdat=nreal+nchanl
     allocate (ozout(nozdat,itxmax))
     do k=1,itxmax
        do i=1,nozdat
           ozout(i,k)=rmiss
        end do
     end do

     iy=0
     im=0
     idd=0
     ihh=0

     read_loop2: do
        call readsb(lunin,iret)
        if (iret/=0) then
           call readmg(lunin,subset,jdate,iret)
           if (iret/=0) exit read_loop2
           cycle read_loop2
        endif

!       extract header information
        call ufbint(lunin,hdrozo,10,1,iret,ozostr)
        call ufbint(lunin,hdrozo2,8,1,iret,ozostr2)
        rsat = hdrozo(1); ksatid=rsat

        if(jsatid == 'aura')kidsat = 785
        if(jsatid == 'npp') kidsat = 224
        if(jsatid == 'n20') kidsat = 225
        if(jsatid == 'n21') kidsat = 226
        if (ksatid /= kidsat) cycle read_loop2

        nmrecs=nmrecs+nloz+1

!    Convert observation location to radians
        slats0= hdrozo(2)
        slons0= hdrozo(3)
        if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop2
        if(slons0< zero) slons0=slons0+r360
        if(slons0==r360) slons0=zero
        dlat_earth_deg = slats0
        dlon_earth_deg = slons0
        dlat_earth = slats0 * deg2rad
        dlon_earth = slons0 * deg2rad

        if(regional)then
           call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
           if(outside) cycle read_loop2
        else
           dlat = dlat_earth
           dlon = dlon_earth
           call grdcrd1(dlat,rlats,nlat,1)
           call grdcrd1(dlon,rlons,nlon,1)
        endif

!    convert observation time to relative time
        idate5(1) = hdrozo(4)  !year
        idate5(2) = hdrozo(5)  !month
        idate5(3) = hdrozo(6)  !day
        idate5(4) = hdrozo(7)  !hour
        idate5(5) = hdrozo(8)  !minute
        call w3fs21(idate5,nmind)

        t4dv=real((nmind-iwinbgn),r_kind)*r60inv
        sstime=real(nmind,r_kind)
        tdiff=(sstime-gstime)*r60inv
        if (l4dvar.or.l4densvar) then
           if (t4dv<zero .OR. t4dv>winlen) cycle read_loop2
        else
           if(abs(tdiff) > twind) cycle read_loop2
        end if

!       extract total ozone
        call ufbint(lunin,totoz,1,1,iret,'OZON')
        if (totoz > badoz ) cycle read_loop2

!    QC for omi_aura
   if (obstype == 'omi') then

!       Bit 10 in TOQF represents row anomaly.
        decimal=int(hdrozo2(6))
        call dec2bin(decimal,binary,14)
        if (binary(10) == 1 ) cycle read_loop2

!    remove the bad scan position data: fovn beyond 25
     if (hdrozo2(7) >=25.0_r_double) cycle read_loop2

   end if
!       only accept flag 0 1, flag 2 is high SZA data which is not used for now
        toq=hdrozo2(5)
        if (toq/=0 .and. toq/=1) cycle read_loop2

!       remove the data in which the C-pair algorithm ((331 and 360 nm) is used.
        if (hdrozo2(8) == 3_r_double .or. hdrozo2(8) == 13_r_double) cycle read_loop2

!       thin OMI/OMPS-NM(or TC8) data

        crit0 = 0.01_r_kind
        timeinflat=r6
        call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
        call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
        if(.not. iuse)cycle read_loop2

        call finalcheck(dist1,crit1,itx,iuse)
        if(.not. iuse)cycle read_loop2

        ndata=ndata+1
        nodata=ndata

        ozout(1,itx)=rsat
        ozout(2,itx)=t4dv
        ozout(3,itx)=dlon               ! grid relative longitude
        ozout(4,itx)=dlat               ! grid relative latitude
        ozout(5,itx)=dlon_earth_deg     ! earth relative longitude (degrees)
        ozout(6,itx)=dlat_earth_deg     ! earth relative latitude (degrees)
        ozout(7,itx)=hdrozo2(5)         ! total ozone quality code
        ozout(8,itx)=hdrozo(10)         ! solar zenith angle
        if (obstype == 'omi') then
           ozout(9,itx)=binary(10)         ! row anomaly flag
        end if
        ozout(10,itx)=hdrozo2(1)        !  cloud amount
        ozout(11,itx)=hdrozo2(4)        !  vzan
        ozout(12,itx)=hdrozo2(2)        !  aerosol index
        ozout(13,itx)=hdrozo2(3)        !  ascending/descending
        ozout(14,itx)=hdrozo2(7)        !  scan position
        ozout(15,itx)=totoz

!       End of loop over observations
     end do read_loop2

! End of OMI/OMPS-NM(or TC8) block

! Process MLS bufr data
  else if ( index(obstype,'mls')/=0 ) then

     nmrecs=0

     open(lunin,file=trim(infile),form='unformatted')
     call openbf(lunin,'IN',lunin)
     call datelen(10)
     call readmg(lunin,subset,idate,iret)
     if (subset == 'NC008015') then
        write(6,*)'READ_OZONE:  MLS data type, subset=',subset
     else
        write(6,*)'READ_OZONE:  *** WARNING: unknown ozone data type, subset=',subset
        write(6,*)' infile=',trim(infile), ', lunin=',lunin, ', obstype=',obstype,', jsatid=',jsatid
        call closbf(lunin)
        close(lunin)
        return
     endif

     read_success=.false.
     if(iret==0) then

        call readsb(lunin,iret)
        if (iret/=0) then
           do
              call readmg(lunin,subset,jdate,iret)
              if (iret/=0) exit
                 call readsb(lunin,iret)
                 if(iret == 0)then
                    read_success=.true.
                    exit
                 end if
           end do
        endif
     endif

     if(read_success)then
!       Get # of vertical pressure levels nloz and MLS NRT data version which depends on nloz
        allocate(hdrmlsl(3,100))
        call ufbrep(lunin,hdrmlsl,3,100,iret,mlstrl)
        nloz=iret
!       for NRT data, mlsv=20 or 30 depending on the nloz
        mlsv=-999
        if(nloz==37) then
           if(index(sis,'mls22')/=0 ) then       !mls v2.2 data
              mlsv=22
           else if(index(sis,'mls20')/=0 ) then  !mls v2 nrt data
              mlsv=20
           end if
        else if (nloz==55) then                !mls v3 nrt data
           if (index(sis,'mls30')/=0 ) then
              mlsv=30
           endif
        else
           write(6,*) 'invalid vertical level number: ', nloz
           write(6,*) '******STOP*******: error reading MLS vertical levels in read_ozone.f90'
           call stop2(338)
        end if
        deallocate(hdrmlsl)

        write(6,*) 'READ_OZONE: MLS data version=',mlsv
        write(6,*) 'READ_OZONE: MLS vertical level number=',nloz

        if (mlsv<0) then
           write(6,*) 'inconsistent MLS versions.  bufr nloz=',nloz,' obsinput sis= ',trim(sis)
           write(6,*) '******STOP*******: error bufr and specified MLS versions'
           call stop2(338)
        end if

!       Allocate arrays
        allocate(hdrmlsl(3,nloz))
        allocate (mlspres(nloz))
        allocate (mlsoz(nloz))
        allocate (mlsozpc(nloz))
        allocate(ipos(nloz))
        allocate (usage1(nloz))

!       Set dependent variables and allocate arrays
        nreal=12
        nchanl=1
        nozdat=nreal+nchanl
        allocate (ozout(nozdat,maxobs))

        do k=1,maxobs
           do i=1,nozdat
              ozout(i,k)=rmiss
           end do
        end do

        ikx=0
        k0=0
        ipos=999
        first=.false.
        do k=1,jpch_oz
           if( (.not. first) .and. index(nusis_oz(k),sis)/=0 ) then
              k0=k
              first=.true.
           end if
           if(first .and. index(nusis_oz(k),sis)/=0 ) then
              ikx=ikx+1
              ipos(ikx)=k0+ikx-1
           end if
        end do

!       Reopen unit to bufr file
        call closbf(lunin)
        open(lunin,file=trim(infile),form='unformatted')
        call openbf(lunin,'IN',lunin)
        call datelen(10)
        call readmg(lunin,subset,idate,iret)
     end if

     read_loop4: do
        if(.not. read_success) exit
        call readsb(lunin,iret)
        if (iret/=0) then
           call readmg(lunin,subset,jdate,iret)
           if (iret/=0) exit read_loop4
           cycle read_loop4
        endif

        do k=1,nloz
           if (iuse_oz(ipos(k)) < 0) then
              usage1(k) = 100._r_kind
           else
              usage1(k) = zero
           endif
        end do

!       extract header information
        call ufbint(lunin,hdrmls,13,1,iret,mlstr)
        rsat = hdrmls(1); ksatid=rsat

        if(jsatid == 'aura')kidsat = 785
        if (ksatid /= kidsat) cycle read_loop4

        nmrecs=nmrecs+nloz

!       Convert observation location to radians
        slats0= hdrmls(2)
        slons0= hdrmls(3)
        if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle read_loop4
        if(slons0< zero) slons0=slons0+r360
        if(slons0==r360) slons0=zero
        dlat_earth_deg = slats0
        dlon_earth_deg = slons0
        dlat_earth = slats0 * deg2rad
        dlon_earth = slons0 * deg2rad

        if(regional)then
           call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
           if(outside) cycle read_loop4
        else
           dlat = dlat_earth
           dlon = dlon_earth
           call grdcrd1(dlat,rlats,nlat,1)
           call grdcrd1(dlon,rlons,nlon,1)
        endif

!    convert observation time to relative time
        idate5(1) = hdrmls(4)  !year
        idate5(2) = hdrmls(5)  !month
        idate5(3) = hdrmls(6)  !day
        idate5(4) = hdrmls(7)  !hour
        idate5(5) = hdrmls(8)  !minute
        call w3fs21(idate5,nmind)

        t4dv=real((nmind-iwinbgn),r_kind)*r60inv
        sstime=real(nmind,r_kind)
        tdiff=(sstime-gstime)*r60inv
        if (l4dvar.or.l4densvar) then
           if (t4dv<zero .OR. t4dv>winlen) cycle read_loop4
        else
           if(abs(tdiff) > twind) cycle read_loop4
        end if

!    v2.2 data screening, only accept:
!    Pressure range(PRLC):       215-0.02mb (lev5-27)
!    Precision(OZMP):            positive OZMP;
!    Status flag(MLST):          only use even number
!    Quality(PCCF):              use >1.2 for data at 215-100mb & low latitude,
!                                use >0.4 for data elsewhere
!    Convergence(CONV):          use <1.8

!    v2 NRT data screening, only accept:
!    Pressure range(PRLC):       68-0.2mb (lev8-23)
!    Precision(OZMP):            positive OZMP;
!    Status flag(MLST):          only use even number
!    Quality(PCCF):              do NOT use <1.2 or >3.0

!    v3 NRT data screening, only accept:
!    Pressure range(PRLC):       261-0.1mb (lev8-43)
!    Precision(OZMP):            positive OZMP;
!    Status flag(MLST):          only use even number
!    Quality(PCCF):              only use if >0.4
!    Convergence(CONV):          use <1.2

!    status: Bit 1 in MLST represents data should not be used
!    Note: in BUFR bits are defined from left to right as: 123456789...
!    whereas in HDF5 (and the nasa document) bits are defined from right to left as: ...876543210
        decimal=int(hdrmls(12))
        call dec2bin(decimal,binary_mls,18)
        if (binary_mls(1) == 1 ) cycle read_loop4

!    v2.2 data, remove data when convergence>1.8
!    v3 NRT data,remove data when convergence>1.2
        if(mlsv==22) then
           if(hdrmls(11) >= 1.8_r_kind) cycle read_loop4
        else if(mlsv==30) then
           if(hdrmls(11) >= 1.2_r_kind) cycle read_loop4
        end if

!       extract pressure, ozone mixing ratio and precision
        call ufbrep(lunin,hdrmlsl,3,nloz,iret,mlstrl)

        do k=1,nloz
           mlspres(k)=log(hdrmlsl(1,k)*0.001_r_kind)    ! mls pressure in Pa, coverted to log(cb)
           mlsoz(k)=hdrmlsl(2,k)                     ! ozone mixing ratio in ppmv
           mlsozpc(k)=hdrmlsl(3,k)                   ! ozone mixing ratio precision in ppmv
!       there is possibility that mlsoz in bufr is 0 or negative or larger than 100 which are not reasonable values.
           if(mlsoz(k)<1.0e-8_r_kind .or. mlsoz(k)>100.0_r_kind ) then
             usage1(k)=1000._r_kind
!         for v2.2 data, if this unreasonable value happens between 215mb (lev5) and 0.02mb (lev27), throw the whole profile
!         for v2 NRT data, if this unreasonable value happens between 68mb (lev8) and 0.2mb (lev23), throw the whole profile
!         for v3 NRT data, if this unreasonable value happens between 261mb (lev8) and 0.1mb (lev43), throw the whole profile
             if(mlsv==22 .and. (k<=27 .and. k>=5)) cycle read_loop4
             if(mlsv==20 .and. (k<=23 .and. k>=8)) cycle read_loop4
             if(mlsv==30 .and. (k<=43 .and. k>=8)) cycle read_loop4
           end if
        end do

        do k=1,nloz
!          pressure range
           if(mlsv==22) then
             if(hdrmlsl(1,k)>21700._r_kind .or. hdrmlsl(1,k)<1._r_kind) usage1(k)=1000._r_kind
           else if(mlsv==20) then
             if(hdrmlsl(1,k)>6900._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind
           else if(mlsv==30) then
             if(hdrmlsl(1,k)>26500._r_kind .or. hdrmlsl(1,k)<10._r_kind) usage1(k)=1000._r_kind
           end if
!          only positive precision accepted
           if(hdrmlsl(3,k)<=0._r_kind) usage1(k)=1000._r_kind
        end do

!      status screening
        hdrmls13=hdrmls(13)*0.1_r_kind
        if(mlsv==22) then
           if (abs(slats0)<30._r_kind) then
              do k=1,nloz
                 if(hdrmlsl(1,k)>10100._r_kind .and. hdrmlsl(1,k)<21700._r_kind) then
                    if(hdrmls13 <= 1.2_r_kind) usage1(k)=1000._r_kind
                 else
                    if(hdrmls13 <= 0.4_r_kind) usage1(k)=1000._r_kind
                 endif
              end do
           else
              if(hdrmls13 <= 0.4_r_kind) then
                 do k=1,nloz
                    usage1(k)=1000._r_kind
                 end do
              end if
           end if
        else if(mlsv==20) then
           if(hdrmls13 <= 1.2_r_kind .or. hdrmls13 >= 3.0_r_kind) then
              do k=1,nloz
                 usage1(k)=1000._r_kind
              end do
           end if
        else if(mlsv==30) then
           if(hdrmls13 <= 0.4_r_kind) then
              do k=1,nloz
                 usage1(k)=1000._r_kind
              end do
           end if
        end if

        do k=1,nloz

           ndata=min(ndata+1,maxobs)
           nodata=ndata
!          if(ndata >= nloz) cycle read_loop4

           ozout(1,ndata)=rsat
           ozout(2,ndata)=t4dv
           ozout(3,ndata)=dlon               ! grid relative longitude
           ozout(4,ndata)=dlat               ! grid relative latitude
           ozout(5,ndata)=dlon_earth_deg     ! earth relative longitude (degrees)
           ozout(6,ndata)=dlat_earth_deg     ! earth relative latitude (degrees)
           ozout(7,ndata)=hdrmls(10)         ! solar zenith angle

           ozout(8,ndata)=usage1(k)          !
           ozout(9,ndata)=mlspres(k)         ! mls pressure in log(cb)
           ozout(10,ndata)=mlsozpc(k)        ! ozone mixing ratio precision in ppmv
           ozout(11,ndata)=float(ipos(k))    ! pointer of obs level index in ozinfo.txt
           ozout(12,ndata)=nloz              ! # of mls vertical levels
           ozout(nreal+1,ndata)=mlsoz(k)     ! ozone mixing ratio in ppmv
        end do

     end do read_loop4

!    End of MLS bufr loop

  endif

  if(nmrecs > 0)then
!    If gome, omps-nm/tc8 or omi data, compress ozout array to thinned data
     if (obstype=='omi' .or. obstype=='gome' .or. obstype=='ompsnm' .or. obstype == 'ompstc8') then
        kk=0
        do k=1,itxmax
           if (ozout(1,k)>zero) then
              kk=kk+1
              do i=1,nozdat
                 ozout(i,kk)=ozout(i,k)
              end do
           endif
        end do
        ndata=kk
        nodata=ndata
     endif

!    Write header record and data to output file for further processing
     call count_obs(ndata,nozdat,ilat,ilon,ozout,nobs)
     write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
     write(lunout) ((ozout(k,i),k=1,nozdat),i=1,ndata)
     nread=nmrecs
   end if

! Deallocate local arrays
  if(allocated(ozout))deallocate(ozout)
  if (obstype == 'sbuv2' .or. obstype == 'ompsnp') deallocate(poz)
  if (index(obstype,'mls')/=0) then
     if(allocated(hdrmlsl))deallocate(hdrmlsl)
     if(allocated(mlspres))deallocate(mlspres)
     if(allocated(mlsoz))deallocate(mlsoz)
     if(allocated(mlsozpc))deallocate(mlsozpc)
     if(allocated(ipos))deallocate(ipos)
     if(allocated(usage1))deallocate(usage1)
  end if

! Close unit to input data file
  call closbf(lunin)
  close(lunin)

! Deallocate satthin arrays
  if (obstype == 'omi' .or. obstype == 'gome' .or. obstype=='ompsnm' .or. obstype == 'ompstc8' )call destroygrids

  return

end subroutine read_ozone