C$Procedure ZZGFCSLV ( GF, coordinate solver )

      SUBROUTINE ZZGFCSLV ( VECDEF, METHOD, TARGET, REF,    ABCORR,
     .                      OBSRVR, DREF,   DVEC,   CRDSYS, CRDNAM,
     .                      RELATE, REFVAL, TOL,    ADJUST, UDSTEP,
     .                      UDREFN, RPT,    UDREPI, UDREPU, UDREPF,
     .                      BAIL,   UDBAIL, MW,     NW,     WORK,
     .                      CNFINE, RESULT                          )

C$ Abstract
C
C     Perform a coordinate search.
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     SPK
C     TIME
C     NAIF_IDS
C     FRAMES
C
C$ Keywords
C
C     GEOMETRY
C     PRIVATE
C     ROOT
C
C$ Declarations

      IMPLICIT NONE

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

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      DOUBLE PRECISION      CNTRCT
      PARAMETER           ( CNTRCT = 1.0D0 )

      CHARACTER*(*)         VECDEF
      CHARACTER*(*)         METHOD
      CHARACTER*(*)         TARGET
      CHARACTER*(*)         REF
      CHARACTER*(*)         ABCORR
      CHARACTER*(*)         OBSRVR
      CHARACTER*(*)         DREF
      DOUBLE PRECISION      DVEC   ( 3 )
      CHARACTER*(*)         CRDSYS
      CHARACTER*(*)         CRDNAM
      CHARACTER*(*)         RELATE
      DOUBLE PRECISION      REFVAL
      DOUBLE PRECISION      TOL
      DOUBLE PRECISION      ADJUST
      EXTERNAL              UDSTEP
      EXTERNAL              UDREFN
      LOGICAL               RPT
      EXTERNAL              UDREPI
      EXTERNAL              UDREPU
      EXTERNAL              UDREPF
      LOGICAL               BAIL
      EXTERNAL              UDBAIL
      LOGICAL               UDBAIL
      INTEGER               MW
      INTEGER               NW
      DOUBLE PRECISION      WORK   ( LBCELL : MW, NW )
      DOUBLE PRECISION      CNFINE ( LBCELL : * )
      DOUBLE PRECISION      RESULT ( LBCELL : * )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     LBCELL     P   Cell lower bound.
C     CNTRCT     P   Existence window contraction magnitude.
C     VECDEF     I   Vector definition.
C     METHOD     I   Computation method.
C     TARGET     I   Target name.
C     REF        I   Reference frame name.
C     ABCORR     I   Aberration correction.
C     OBSRVR     I   Observer name.
C     DREF       I   Ray's direction vector frame.
C     DVEC       I   Ray's direction vector.
C     CRDSYS     I   Coordinate system name.
C     CRDNAM     I   Coordinate name.
C     RELATE     I   Relational operator.
C     REFVAL     I   Reference value.
C     TOL        I   Convergence tolerance.
C     ADJUST     I   Absolute extremum adjustment value.
C     UDSTEP     I   Step size routine.
C     UDREFN     I   Search refinement routine.
C     RPT        I   Progress report flag.
C     UDREPI     I   Progress report initialization routine.
C     UDREPU     I   Progress report update routine.
C     UDREPF     I   Progress report termination routine.
C     BAIL       I   Bail-out flag.
C     UDBAIL     I   Bail-out status function.
C     MW         I   Workspace window size.
C     NW         I   Workspace window count.
C     WORK      I-O  Workspace window array.
C     CNFINE     I   Confinement window.
C     RESULT     O   Result window.
C
C$ Detailed_Input
C
C
C     VECDEF     Every coordinate computed by this routine is a
C                function of an underlying vector. VECDEF is a short
C                string describing the means by which the vector of
C                interest is defined. Only parameters from the Fortran
C                INCLUDE file zzgf.inc should be used. Parameter names
C                and meanings are:
C
C                   POSDEF               Vector is position of
C                                        target relative to observer.
C
C                   SOBDEF               Vector is sub-observer
C                                        point on target body.  Vector
C                                        points from target body
C                                        center to sub-observer point.
C                                        The target must be an extended
C                                        body modeled as a triaxial
C                                        ellipsoid.
C
C                   SINDEF               Vector is ray-surface intercept
C                                        point on target body. Vector
C                                        points from target body
C                                        center to sub-observer point.
C                                        The target must be an extended
C                                        body modeled as a triaxial
C                                        ellipsoid.
C
C                Case, leading and trailing blanks ARE significant
C                in the string VECDEF.
C
C
C     METHOD     is a string specifying the computational method
C                applicable to the vector of interest. When VECDEF
C                is the parameter
C
C                   SOBDEF
C
C                METHOD should be set to one of the values accepted
C                by the SPICELIB routine SUBPNT.
C
C                When VECDEF is the parameter
C
C                   SINDEF
C
C                METHOD should be set to one of the values accepted
C                by the SPICELIB routine SINCPT.
C
C                METHOD is ignored if VECDEF is set to
C
C                   POSDEF
C
C                Case, leading and trailing blanks are not significant
C                in the string METHOD.
C
C
C     TARGET     is the name of the target object.
C
C
C     REF        is the name of the reference frame relative to which
C                the vector of interest is specified. The specified
C                condition applies to the specified coordinate of
C                of this vector in frame REF.
C
C                When geodetic coordinates are used, the reference
C                ellipsoid is assumed to be that associated with
C                the central body of the frame designated by REF.
C                In this case, the central body of the frame must
C                be an extended body.
C
C                Case, leading and trailing blanks are not significant
C                in the string REF.
C
C
C     ABCORR     indicates the aberration corrections to be applied to
C                the state of the target body to account for one-way
C                light time and stellar aberration.  The orientation
C                of the target body will also be corrected for one-way
C                light time when light time corrections are requested.
C
C                Supported aberration correction options for
C                observation (case where radiation is received by
C                observer at ET) are:
C
C                  'NONE'          No correction.
C                  'LT'            Light time only.
C                  'LT+S'          Light time and stellar aberration.
C                  'CN'            Converged Newtonian (CN) light time.
C                  'CN+S'          CN light time and stellar aberration.
C
C                Supported aberration correction options for
C                transmission (case where radiation is emitted from
C                observer at ET) are:
C
C                  'XLT'           Light time only.
C                  'XLT+S'         Light time and stellar aberration.
C                  'XCN'           Converged Newtonian (CN) light time.
C                  'XCN+S'         CN light time and stellar aberration.
C
C                For detailed information, see the geometry finder
C                required reading, gf.req.  Also see the header of
C                SPKEZR, which contains a detailed discussion of
C                aberration corrections.
C
C                Case, leading and trailing blanks are not significant
C                in the string ABCORR.
C
C
C     OBSRVR     is the name of the observer.
C
C
C     DREF       is the name of the reference frame relative to which a
C                ray's direction vector is expressed. This may be any
C                frame supported by the SPICE system, including
C                built-in frames (documented in the Frames Required
C                Reading) and frames defined by a loaded frame kernel
C                (FK). The string DREF is case-insensitive, and leading
C                and trailing blanks in DREF are not significant.
C
C                When DREF designates a non-inertial frame, the
C                orientation of the frame is evaluated at an epoch
C                dependent on the frame's center and, if the center is
C                not the observer, on the selected aberration
C                correction. See the description of the direction
C                vector DVEC for details.
C
C
C     DVEC       Ray direction vector emanating from the observer. The
C                intercept with the target body's surface of the ray
C                defined by the observer and DVEC is sought.
C
C                DVEC is specified relative to the reference frame
C                designated by DREF.
C
C                Non-inertial reference frames are treated as follows:
C                if the center of the frame is at the observer's
C                location, the frame is evaluated at ET. If the frame's
C                center is located elsewhere, then letting LTCENT be
C                the one-way light time between the observer and the
C                central body associated with the frame, the
C                orientation of the frame is evaluated at ET-LTCENT,
C                ET+LTCENT, or ET depending on whether the requested
C                aberration correction is, respectively, for received
C                radiation, transmitted radiation, or is omitted.
C                LTCENT is computed using the method indicated by
C                ABCORR.
C
C
C     CRDSYS     is the name of the coordinate system to which the
C                coordinate of interest belongs. Allowed values are
C                those defined in the GF Fortran INCLUDE file
C
C                   zzgf.inc.
C
C                Note that when geodetic coordinates are used, the
C                reference ellipsoid is that associated with the
C                central body of the reference frame designated by REF.
C                The central body must be an extended body in this
C                case.
C
C                Case, leading and trailing blanks are not significant
C                in the string CRDSYS.
C
C
C     CRDNAM     is the name of the coordinate of interest:  this is
C                the coordinate to which the specified condition
C                applies.  The set of coordinate names is a function of
C                the coordinate system. Allowed values are those
C                defined in the GF Fortran INCLUDE file
C
C                   zzgf.inc.
C
C                Case, leading and trailing blanks are not significant
C                in the string CRDNAM.
C
C
C     RELATE      is a relational operator used to define a constraint
C                 on the specified coordinate. The result window found
C                 by this routine indicates the time intervals where
C                 the constraint is satisfied. Supported values of
C                 RELATE and corresponding meanings are shown below:
C
C                    '>'      Coordinate is greater than the reference
C                             value REFVAL.
C
C                    '='      Coordinate is equal to the reference
C                             value REFVAL.
C
C                    '<'      Coordinate is less than the reference
C                             value REFVAL.
C
C
C                   'ABSMAX'  Coordinate is at an absolute maximum.
C
C                   'ABSMIN'  Coordinate is at an absolute  minimum.
C
C                   'LOCMAX'  Coordinate is at a local maximum.
C
C                   'LOCMIN'  Coordinate is at a local minimum.
C
C                The caller may indicate that the region of interest
C                is the set of time intervals where the coordinate is
C                within a specified tolerance of an absolute extremum.
C                The argument ADJUST (described below) is used to
C                specify this tolerance.
C
C                Local extrema are considered to exist only in the
C                interiors of the intervals comprising the confinement
C                window:  a local extremum cannot exist at a boundary
C                point of the confinement window.
C
C                Case is not significant in the string RELATE.
C
C
C     REFVAL     is the reference value used to define equality or
C                inequality conditions.
C
C                If the coordinate has the dimension "length," then
C                REFVAL has units of kilometers.
C
C                If the coordinate has the dimension "angle," then
C                REFVAL has units of radians.
C
C                When the coordinate of interest is longitude, REFVAL
C                is interpreted as though it were translated, if
C                necessary, by an integer multiple of 2*pi to place it
C                in the standard range for longitude: (-pi, pi].
C                Similarly, when the coordinate of interest is right
C                ascension, REFVAL is interpreted as though it were
C                translated, if necessary, by an integer multiple of
C                2*pi into the range [0, 2*pi).
C
C                Example:  suppose REFVAL is set to -4.5. Then the
C                          condition
C
C                   longitude equals REFVAL
C
C                is interpreted as
C
C                   longitude equals -0.5 * pi
C
C                so the solution window for this condition may well
C                be non-empty.
C
C                REFVAL is ignored if RELATE is not an equality or
C                inequality operator.
C
C
C     TOL        is a tolerance value used to determine convergence of
C                root-finding operations. TOL is measured in TDB
C                seconds and is greater than zero.
C
C
C     ADJUST     The amount by which the coordinate is allowed to vary
C                from an absolute extremum. ADJUST is not used for
C                equality or inequality conditions. ADJUST must not be
C                negative.
C
C                If ADJUST is positive and a search for an absolute
C                minimum is performed, the resulting schedule contains
C                time intervals when the specified coordinate has
C                values between ABSMIN and ABSMIN + ADJUST.
C
C                If the search is for an absolute maximum, the
C                corresponding range is  between ABSMAX - ADJUST and
C                ABSMAX.
C
C
C     UDSTEP     is a routine that computes a time step used to search
C                for a transition of the state of the specified
C                coordinate. In the context of this routine's
C                algorithm, a "state transition" occurs where the
C                coordinate's time derivative changes from negative to
C                non-negative or vice versa.
C
C                This routine relies on UDSTEP returning step sizes
C                small enough so that state transitions within the
C                confinement window are not overlooked.  There must
C                never be two roots A and B separated by less than
C                STEP, where STEP is the minimum step size returned by
C                UDSTEP for any value of ET in the interval [A, B].
C
C                The calling sequence for UDSTEP is:
C
C                   CALL UDSTEP ( ET, STEP )
C
C                where:
C
C                   ET      is the input start time from which the
C                           algorithm is to search forward for a state
C                           transition. ET is expressed as seconds past
C                           J2000 TDB. ET is a DOUBLE PRECISION number.
C
C                   STEP    is the output step size. STEP indicates
C                           how far to advance ET so that ET and
C                           ET+STEP may bracket a state transition and
C                           definitely do not bracket more than one
C                           state transition. STEP is a DOUBLE
C                           PRECISION number. Units are TDB seconds.
C
C                If a constant step size is desired, the routine GFSTEP
C                may be used. GFSTEP returns the step size that was set
C                via the most recent call to GFSSTP.
C
C
C     UDREFN     is the name of the externally specified routine that
C                computes a refinement in the times that bracket a
C                transition point. In other words, once a pair of
C                times have been detected such that the system is in
C                different states at each of the two times, UDREFN
C                selects an intermediate time which should be closer to
C                the transition state than one of the two known times.
C                The calling sequence for UDREFN is:
C
C                   CALL UDREFN ( T1, T2, S1, S2, T )
C
C                where the inputs are:
C
C                   T1    is a time when the system is in state S1. T1
C                         is a DOUBLE PRECISION number.
C
C                   T2    is a time when the system is in state S2. T2
C                         is a DOUBLE PRECISION number and is assumed
C                         to be larger than T1.
C
C                   S1    is the state of the system at time T1.
C                         S1 is a LOGICAL value.
C
C                   S2    is the state of the system at time T2.
C                         S2 is a LOGICAL value.
C
C                UDREFN may use or ignore the S1 and S2 values.
C
C                The output is:
C
C                   T     is next time to check for a state transition.
C                         T is a DOUBLE PRECISION number between T1 and
C                         T2.
C
C                If a simple bisection method is desired, the routine
C                GFREFN may be used. This is the default option.
C
C
C     RPT        is a logical variable which controls whether the
C                progress reporter is on or off; setting RPT
C                to .TRUE. enables progress reporting.
C
C
C     UDREPI     is a user-defined subroutine that initializes a
C                progress report. When progress reporting is
C                enabled, UDREPI is called at the start of a search
C                pass (see the implementation of ZZGFREL for details on
C                search passes).  The calling sequence of UDREPI is
C
C                   UDREPI ( CNFINE, RPTPRE, RPTSUF )
C
C                   DOUBLE PRECISION    CNFINE ( LBCELL : * )
C                   CHARACTER*(*)       RPTPRE
C                   CHARACTER*(*)       RPTSUF
C
C                where
C
C                   CNFINE
C
C                is the confinement window passed into ZZGFREL, and
C
C                   RPTPRE
C                   RPTSUF
C
C                are prefix and suffix strings used in the progress
C                report:  these strings are intended to bracket a
C                representation of the fraction of work done.
C
C                SPICELIB provides the default progress reporting
C                initialization routine GFREPI. If GFREPI is used, then
C                the progress reporting update and termination routines
C                GFREPU and GFREPF must be used as well.
C
C
C     UDREPU     is a user-defined subroutine that updates the
C                progress report for a search pass. The calling
C                sequence of UDREPU is
C
C                   UDREPU (IVBEG, IVEND, ET )
C
C                   DOUBLE PRECISION      ET
C                   DOUBLE PRECISION      IVBEG
C                   DOUBLE PRECISION      IVEND
C
C                where ET is an epoch belonging to the confinement
C                window, IVBEG and IVEND are the start and stop times,
C                respectively of the current confinement window
C                interval.  The ratio of the measure of the portion
C                of CNFINE that precedes ET to the measure of CNFINE
C                would be a logical candidate for the search's
C                completion percentage; however the method of
C                measurement is up to the user.
C
C
C     UDREPF     is a user-defined subroutine that finalizes a
C                progress report. UDREPF has no arguments.
C
C
C     BAIL       is a logical flag indicating whether or not interrupt
C                signal handling is enabled. Setting BAIL to .TRUE.
C                enables interrupt signal handling: the GF system will
C                then call UDBAIL to check for interrupt signals.
C
C
C     UDBAIL     is the name of a user defined logical function that
C                checks to see whether an interrupt signal has been
C                issued from, e.g. the keyboard. UDBAIL is used only
C                when BAIL is set to .TRUE. If interrupt handling is
C                not used, the SPICELIB function GFBAIL should be
C                passed in as the actual bail-out function argument.
C
C
C     MW         is the cell size of the windows in the workspace array
C                WORK.
C
C
C     NW         is the number of windows in the workspace array WORK.
C                NW must be at least as large as the parameter NWMAX.
C
C
C     WORK       is an array used to store workspace windows. This
C                array has dimensions ( LBCELL : MW, NW).
C
C
C     CNFINE     is a SPICE window that confines the bounds of the
C                search.
C
C                For coordinates defined by ray-target surface
C                intercepts, the effective confinement window is
C                obtained by searching for times within CNFINE when the
C                specified intercept and its derivative with respect to
C                time are computable. The window resulting from this
C                search is then contracted by CNTRCT+TOL seconds at
C                both left and right endpoints; this contracted window
C                is called the "existence window," since the surface
C                intercept and its time derivative are expected to be
C                computable on this contracted window. The user must
C                select CNFINE so that this requirement is met.
C
C
C     RESULT     is an initialized SPICE window. RESULT must be large
C                enough to hold all of the intervals, within the
C                confinement window, on which the specified condition
C                is met.
C
C                RESULT must be initialized by the caller via the
C                SPICELIB routine SSIZED.
C
C
C$ Detailed_Output
C
C     WORK       has undefined contents on output.
C
C
C     RESULT     is a SPICELIB window containing the intersection of
C                the confinement window and the set of time intervals
C                when the value of the specified coordinate satisfies
C                constraints specified by RELATE and ADJUST.
C
C                For coordinates defined by ray-target surface
C                intercepts, RESULT is further restricted to the window
C                over which the intercept and its derivative with
C                respect to time are computable. See the description of
C                CNFINE above for details.
C
C$ Parameters
C
C     LBCELL     is the lower bound for SPICELIB cells.
C
C     CNTRCT     is the contraction magnitude used to prepare the
C                "existence window" for use as a confinement window.
C                The existence window is applicable only to coordinates
C                of surface intercepts: it is the result of contracting
C                the window over which the surface intercept and its
C                time derivative are computable by CNTRCT+TOL. Units
C                are TDB seconds.
C
C$ Exceptions
C
C     1)  If the workspace window count NW is less than NWMAX, the
C         error SPICE(TOOFEWWINDOWS) is signaled.
C
C     2)  If the workspace window size MW is less than 2, the
C         error SPICE(WINDOWSTOOSMALL) is signaled.
C
C     3)  If a workspace window or the result window is too small
C         to accommodate the required number of intervals,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     4)  If either the observer or target names cannot be mapped
C         to ID codes, the error will be diagnosed by routines in the
C         call tree of this routine.
C
C     5)  If the observer and target have the same ID codes, the
C         error will be diagnosed by routines in the call tree of this
C         routine.
C
C     6)  If the vector definition VECDEF is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     7)  If the computation method METHOD is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     8)  If the aberration correction ABCORR is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     9)  If the coordinate system name CRDSYS is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     10) If the coordinate name CRDNAM is not recognized,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     11) If the frame REF is not recognized by the frames subsystem,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     12) If VECDEF calls for a computation involving a target surface
C         intercept point and the name and ID code of the frame DREF
C         associated with the target body are not available from the
C         frame subsystem, the error will be diagnosed by routines in
C         the call tree of this routine.
C
C     13) If VECDEF calls for a computation involving a target surface
C         intercept point and the direction vector DVEC is the zero
C         vector, the error will be diagnosed by routines in the call
C         tree of this routine.
C
C     14) If VECDEF calls for a computation involving a target surface
C         point and the radii defining the reference ellipsoid
C         associated with the target body are not available in the
C         kernel pool, the error will be diagnosed by routines in the
C         call tree of this routine.
C
C     15) If VECDEF calls for a computation involving a target surface
C         point and the frame REF is not centered on the target body,
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     16) If geodetic or planetographic coordinates are used and the
C         radii defining the reference ellipsoid associated with the
C         center of the frame REF are not available in the kernel pool,
C         the error will be diagnosed by routines in the call tree of
C         this routine.
C
C     17) If geodetic or planetographic coordinates are used and the
C         first equatorial radius of the reference ellipsoid associated
C         with the center of the frame REF is zero, the error will be
C         diagnosed by routines in the call tree of this routine.
C
C     18) If geodetic or planetographic coordinates are used and the
C         equatorial radii of the reference ellipsoid associated
C         with the center of the frame REF are unequal, the error
C         SPICE(NOTSUPPORTED) is signaled.
C
C     19) If geodetic or planetographic coordinates are used and the
C         reference ellipsoid associated with the center of the frame
C         REF is degenerate (one or more radii are non-positive),
C         the error will be diagnosed by routines in the call tree
C         of this routine.
C
C     20) If ADJUST is negative, the error SPICE(VALUEOUTOFRANGE)
C         is signaled.
C
C     21) If TOL is non-positive, the error SPICE(VALUEOUTOFRANGE)
C         is signaled.
C
C     21) If RELATE is not a supported relational operator
C         specification, the error SPICE(NOTRECOGNIZED) is signaled.
C
C$ Files
C
C     See the discussion in the Files section of the header of the
C     umbrella subroutine ZZGFCOU.
C
C$ Particulars
C
C     This routine handles coordinate search set-up and execution
C     activities for GFEVNT.
C
C     For a surface intercept coordinate search, this routine finds the
C     "existence window," within the input confinement window, for the
C     surface intercept and its time derivative. The existence window
C     is contracted by CNTRCT seconds; this contracted window is then
C     used as the confinement window for the search.
C
C$ Examples
C
C     See GFEVNT and ZZGFLONG.
C
C$ Restrictions
C
C     1)  The interface and functionality of this set of routines may
C         change without notice.  These routines should be called only
C         by SPICELIB routines.
C
C     2)  ZZGFCSLV must be called prior to use of any of the other
C         entry points.
C
C     3)  This routine has the following couplings with other
C         SPICE routines:
C
C            - The set of allowed aberration corrections must
C              be kept in sync with the set supported by the
C              SPK API routines.
C
C            - The set of vector definitions must be kept in
C              sync with the set supported by GFEVNT.
C
C            - The set of supported coordinate systems must be kept in
C              sync with the set supported by zzgf.inc.
C
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.2.0, 04-APR-2011 (EDW)
C
C        Replaced use of rooutines ZZGFREL with ZZGFRELX, and
C        ZZGFSOLV with ZZGFSOLVX. ZZGFCOIN argument list edited
C        to remove the unneeded argument REFVAL.
C
C        The code changes for ZZGFRELX use should not affect the
C        numerical results of GF computations.
C
C-    SPICELIB Version 1.0.0 06-MAR-2009 (NJB) (EDW)
C
C-&

C$ Index_Entries
C
C     coordinate search
C
C-&

      EXTERNAL              UDF

C
C     SPICELIB functions
C
      INTEGER               ISRCHC
      INTEGER               WNCARD

      LOGICAL               FAILED
      LOGICAL               RETURN

      EXTERNAL              ZZGFCODC
      EXTERNAL              ZZGFCOG
      EXTERNAL              ZZGFCOEX
      EXTERNAL              ZZGFUDLT

C
C     Local parameters
C
      INTEGER               LNSIZE
      PARAMETER           ( LNSIZE = 80 )

      INTEGER               MXPASS
      PARAMETER           ( MXPASS  = 3 )

      INTEGER               XPASS
      PARAMETER           ( XPASS  = 3 )

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

C
C     MAXOP is the maximum string length for comparison operators.
C     MAXOP may grow if new comparisons are added.
C
      INTEGER               MAXOP
      PARAMETER           ( MAXOP = 6 )

C
C     Local variables
C
      CHARACTER*(MAXOP)     CNAMES ( NC )
      CHARACTER*(LNSIZE)    LOCCRD
      CHARACTER*(LNSIZE)    LOCVDF
      CHARACTER*(MXBEGM)    PREBUF ( MXPASS )
      CHARACTER*(MXBEGM)    RPTPRE ( MXPASS )
      CHARACTER*(MXENDM)    RPTSUF ( MXPASS )
      CHARACTER*(MAXOP)     UOP

      DOUBLE PRECISION      EXCON
      DOUBLE PRECISION      FINISH
      DOUBLE PRECISION      START

      INTEGER               I
      INTEGER               LOC
      INTEGER               NPASS

      LOGICAL               LOCALX
      LOGICAL               NOADJX

C
C     Saved variables
C
      SAVE                  RPTPRE
      SAVE                  RPTSUF

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

      DATA                  RPTPRE / 'Coordinate pass 1 of # ',
     .                               'Coordinate pass 2 of # ',
     .                               'Intercept existence pass 1 of 1' /

      DATA                  RPTSUF / 3 * 'done.' /

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

      CALL CHKIN ( 'ZZGFCSLV' )

C
C     Check the workspace window count.
C
      IF ( NW .LT. NWMAX ) THEN

         CALL SETMSG ( 'Workspace window count was # but must be '
     .   //            'at least #.'                              )
         CALL ERRINT ( '#', NW                                    )
         CALL ERRINT ( '#', NWMAX                                 )
         CALL SIGERR ( 'SPICE(TOOFEWWINDOWS)'                     )
         CALL CHKOUT ( 'ZZGFCSLV'                                 )
         RETURN

      END IF

C
C     Check the workspace window size. The minimum size that
C     makes any sense is 2.
C
      IF ( MW .LT. 2 ) THEN

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

      END IF

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

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

      END IF

C
C     Make sure TOL is positive.
C
      IF ( TOL .LE. 0.D0 ) THEN

         CALL SETMSG ( 'TOL was #; must be positive.' )
         CALL ERRDP  ( '#',  TOL                      )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'       )
         CALL CHKOUT ( 'ZZGFCSLV'                     )
         RETURN

      END IF

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

      LOC = ISRCHC ( UOP, NC, CNAMES )

      IF ( LOC .EQ. 0 ) THEN

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

      END IF

C
C     Initialize the workspace windows.
C
      DO I = 1, NW
         CALL SSIZED ( MW, WORK(LBCELL,I) )
      END DO

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

C
C     Create a left-justified, compressed copy of the
C     input vector definition method.
C
      CALL LJUST  ( VECDEF,         LOCVDF )
      CALL CMPRSS ( ' ', 1, LOCVDF, LOCVDF )
      CALL UCASE  ( LOCVDF,         LOCVDF )

C
C     If the vector definition method is "surface intercept,"
C     find the "existence window": the window over which
C     the intercept and its time derivative are computable.
C
      IF ( LOCVDF .EQ. SINDEF ) THEN
C
C        Initialize the search for the existence window.
C
         CALL ZZGFCOIN ( VECDEF, METHOD, TARGET,
     .                   REF,   ABCORR,  OBSRVR, DREF,
     .                   DVEC,  CRDSYS,  CRDNAM )

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

C
C        This routine presumes that UDSTEP has been initialized, so we
C        don't attempt to reset the step.
C
C        If progress reporting is enabled, initialize the progress
C        report for the existence window search.
C
         IF ( RPT ) THEN
            CALL UDREPI ( CNFINE, RPTPRE(XPASS), RPTSUF(XPASS) )
         END IF

C
C        ZZGFSOLV will add the result of each search to the workspace
C        window
C
C           WORK(LBCELL,EXWIDX)
C
C        Initialize this window.
C
         CALL SSIZED ( MW, WORK(LBCELL,EXWIDX) )

C
C        Search each interval of the confinement window.
C
         DO I = 1, WNCARD( CNFINE )

            CALL WNFETD ( CNFINE, I, START, FINISH )

            CALL ZZGFSOLVX( UDF,    ZZGFCOEX,  UDSTEP,   UDREFN,
     .                      BAIL,   UDBAIL,    .FALSE.,  0.D0,
     .                      START,  FINISH,    TOL,      RPT,
     .                      UDREPU, WORK(LBCELL,EXWIDX)      )

            IF (  FAILED()  ) THEN
               CALL CHKOUT ( 'ZZGFCSLV'  )
               RETURN
            END IF
C
C           If interrupt processing is enabled, check to see
C           whether an interrupt has occurred.
C
            IF ( BAIL ) THEN

               IF ( UDBAIL () ) THEN
                  CALL CHKOUT ( 'ZZGFCSLV' )
                  RETURN
               END IF

            END IF

         END DO

C
C        If progress reporting is enabled, terminate the report
C        for this pass.
C
         IF ( RPT ) THEN
            CALL UDREPF
         END IF

C
C        For safety, contract the existence window. Store
C        the result in the workspace.
C
         EXCON = TOL + CNTRCT

         CALL WNCOND ( EXCON, EXCON, WORK(LBCELL,EXWIDX) )

      ELSE
C
C        Simply copy the confinement window to the workspace.
C
         CALL COPYD ( CNFINE, WORK(LBCELL, EXWIDX ) )

      END IF

C
C     If progress reporting is enabled, set the report prefix array
C     according to the quantity and the relational operator.
C
      IF ( RPT ) THEN

C
C        We'll use the logical flag LOCALX to indicate a local extremum
C        operator and the flag NOADJX to indicate an absolut extremum
C        operator with zero adjustment.
C
         LOCALX =   ( UOP .EQ. 'LOCMIN' ) .OR. ( UOP .EQ. 'LOCMAX' )

         NOADJX =  ( ADJUST .EQ.  0.D0    ) .AND.
     .           ( ( UOP    .EQ. 'ABSMIN' ) .OR. ( UOP .EQ. 'ABSMAX' ) )
     .

         IF ( LOCALX .OR. NOADJX ) THEN
C
C           These operators correspond to 1-pass searches.
C
            NPASS = 1
         ELSE
            NPASS = 2
         END IF

C
C        Fill in the prefix strings.
C
         DO I = 1, NPASS
            CALL REPMI ( RPTPRE(I), '#', NPASS, PREBUF(I) )
         END DO

      END IF

C
C     Create a left-justified, compressed, upper case copy of the
C     input coordinate name.
C
      CALL LJUST  ( CRDNAM,         LOCCRD )
      CALL CMPRSS ( ' ', 1, LOCCRD, LOCCRD )
      CALL UCASE  ( LOCCRD,         LOCCRD )

C
C     If the coordinate of interest is longitude or right ascension, we
C     have a special case, since the mapping from Cartesian to
C     latitudinal coordinates has a branch discontinuity.
C
      IF ( ( LOCCRD .EQ. LONCRD ) .OR. ( LOCCRD .EQ. RACRD ) ) THEN

C
C        The coordinate is longitude or right ascension.
C
         CALL ZZGFLONG ( VECDEF, METHOD, TARGET, REF,    ABCORR,
     .                   OBSRVR, DREF,   DVEC,   CRDSYS, CRDNAM,
     .                   RELATE, REFVAL, TOL,    ADJUST, UDSTEP,
     .                   UDREFN, RPT,    UDREPI, UDREPU, UDREPF,
     .                   BAIL,   UDBAIL, MW,     NW,     WORK,
     .                   WORK(LBCELL, EXWIDX ),  RESULT         )

      ELSE

C
C        This is the normal case.
C
C        Initialize the coordinate quantity utilities.
C
         CALL ZZGFCOIN ( VECDEF, METHOD, TARGET,
     .                   REF,   ABCORR,  OBSRVR, DREF,
     .                   DVEC,  CRDSYS,  CRDNAM )

C
C        Perform the search.
C
         CALL ZZGFRELX( UDSTEP,   UDREFN,              ZZGFCODC,
     .                  ZZGFUDLT, ZZGFCOG,
     .                  RELATE,   REFVAL,              TOL,
     .                  ADJUST,   WORK(LBCELL,EXWIDX), MW,
     .                  NW,       WORK,                RPT,
     .                  UDREPI,   UDREPU,              UDREPF,
     .                  PREBUF,   RPTSUF,              BAIL,
     .                  UDBAIL,   RESULT                        )

      END IF

      CALL CHKOUT ( 'ZZGFCSLV' )
      RETURN

      END


MODULE zdftke
  USE oce
  USE phycst
  USE dom_oce
  USE domvvl
  USE sbc_oce
  USE zdfdrg
  USE zdfmxl
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE lbclnk
  USE prtctl
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: zdf_tke
  PUBLIC :: zdf_tke_init
  PUBLIC :: tke_rst
  LOGICAL :: ln_mxl0
  INTEGER :: nn_mxl
  REAL(KIND = wp) :: rn_mxl0
  INTEGER :: nn_pdl
  REAL(KIND = wp) :: rn_ediff
  REAL(KIND = wp) :: rn_ediss
  REAL(KIND = wp) :: rn_ebb
  REAL(KIND = wp) :: rn_emin
  REAL(KIND = wp) :: rn_emin0
  REAL(KIND = wp) :: rn_bshear
  LOGICAL :: ln_drg
  INTEGER :: nn_etau
  INTEGER :: nn_htau
  REAL(KIND = wp) :: rn_efr
  REAL(KIND = wp) :: rn_eice
  LOGICAL :: ln_lc
  REAL(KIND = wp) :: rn_lc
  REAL(KIND = wp) :: ri_cri
  REAL(KIND = wp) :: rmxl_min
  REAL(KIND = wp) :: rhftau_add = 1.E-3_wp
  REAL(KIND = wp) :: rhftau_scl = 1.0_wp
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: htau
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: dissl
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: apdlr
  CONTAINS
  INTEGER FUNCTION zdf_tke_alloc()
    ALLOCATE(htau(jpi, jpj), dissl(jpi, jpj, jpk), apdlr(jpi, jpj, jpk), STAT = zdf_tke_alloc)
    IF (lk_mpp) CALL mpp_sum(zdf_tke_alloc)
    IF (zdf_tke_alloc /= 0) CALL ctl_warn('zdf_tke_alloc: failed to allocate arrays')
  END FUNCTION zdf_tke_alloc
  SUBROUTINE zdf_tke(kt, p_sh2, p_avm, p_avt)
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: p_sh2
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: p_avm, p_avt
    CALL tke_tke(gdepw_n, e3t_n, e3w_n, p_sh2, p_avm, p_avt)
    CALL tke_avn(gdepw_n, e3t_n, e3w_n, p_avm, p_avt)
  END SUBROUTINE zdf_tke
  SUBROUTINE tke_tke(pdepw, p_e3t, p_e3w, p_sh2, p_avm, p_avt)
    USE zdf_oce, ONLY: en
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: pdepw
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: p_e3t, p_e3w
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: p_sh2
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: p_avm, p_avt
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zetop, zebot, zmsku, zmskv
    REAL(KIND = wp) :: zrhoa = 1.22
    REAL(KIND = wp) :: zcdrag = 1.5E-3
    REAL(KIND = wp) :: zbbrau, zri
    REAL(KIND = wp) :: zfact1, zfact2, zfact3
    REAL(KIND = wp) :: ztx2, zty2, zcof
    REAL(KIND = wp) :: ztau, zdif
    REAL(KIND = wp) :: zus, zwlc, zind
    REAL(KIND = wp) :: zzd_up, zzd_lw
    INTEGER, DIMENSION(jpi, jpj) :: imlc
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhlc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zpelc, zdiag, zd_up, zd_lw
    !$ACC KERNELS
    zbbrau = rn_ebb / rau0
    zfact1 = - .5_wp * rdt
    zfact2 = 1.5_wp * rdt * rn_ediss
    zfact3 = 0.5_wp * rn_ediss
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        en(ji, jj, 1) = MAX(rn_emin0, zbbrau * taum(ji, jj)) * tmask(ji, jj, 1)
      END DO
    END DO
    !$ACC END KERNELS
    IF (ln_isfcav) THEN
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          en(ji, jj, mikt(ji, jj)) = rn_emin * tmask(ji, jj, 1)
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (ln_drg) THEN
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zmsku = (2. - umask(ji - 1, jj, mbkt(ji, jj)) * umask(ji, jj, mbkt(ji, jj)))
          zmskv = (2. - vmask(ji, jj - 1, mbkt(ji, jj)) * vmask(ji, jj, mbkt(ji, jj)))
          zebot = - 0.001875_wp * rCdU_bot(ji, jj) * SQRT((zmsku * (ub(ji, jj, mbkt(ji, jj)) + ub(ji - 1, jj, mbkt(ji, jj)))) ** 2 + (zmskv * (vb(ji, jj, mbkt(ji, jj)) + vb(ji, jj - 1, mbkt(ji, jj)))) ** 2)
          en(ji, jj, mbkt(ji, jj) + 1) = MAX(zebot, rn_emin) * ssmask(ji, jj)
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_isfcav) THEN
        !$ACC KERNELS
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zmsku = (2. - umask(ji - 1, jj, mikt(ji, jj)) * umask(ji, jj, mikt(ji, jj)))
            zmskv = (2. - vmask(ji, jj - 1, mikt(ji, jj)) * vmask(ji, jj, mikt(ji, jj)))
            zetop = - 0.001875_wp * rCdU_top(ji, jj) * SQRT((zmsku * (ub(ji, jj, mikt(ji, jj)) + ub(ji - 1, jj, mikt(ji, jj)))) ** 2 + (zmskv * (vb(ji, jj, mikt(ji, jj)) + vb(ji, jj - 1, mikt(ji, jj)))) ** 2)
            en(ji, jj, mikt(ji, jj)) = MAX(zetop, rn_emin) * (1._wp - tmask(ji, jj, 1))
          END DO
        END DO
        !$ACC END KERNELS
      END IF
    END IF
    IF (ln_lc) THEN
      !$ACC KERNELS
      zpelc(:, :, 1) = MAX(rn2b(:, :, 1), 0._wp) * pdepw(:, :, 1) * p_e3w(:, :, 1)
      DO jk = 2, jpk
        zpelc(:, :, jk) = zpelc(:, :, jk - 1) + MAX(rn2b(:, :, jk), 0._wp) * pdepw(:, :, jk) * p_e3w(:, :, jk)
      END DO
      zcof = 0.5 * 0.016 * 0.016 / (zrhoa * zcdrag)
      imlc(:, :) = mbkt(:, :) + 1
      DO jk = jpkm1, 2, - 1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zus = zcof * taum(ji, jj)
            IF (zpelc(ji, jj, jk) > zus) imlc(ji, jj) = jk
          END DO
        END DO
      END DO
      DO jj = 1, jpj
        DO ji = 1, jpi
          zhlc(ji, jj) = pdepw(ji, jj, imlc(ji, jj))
        END DO
      END DO
      zcof = 0.016 / SQRT(zrhoa * zcdrag)
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zus = zcof * SQRT(taum(ji, jj))
            zind = 0.5 - SIGN(0.5, pdepw(ji, jj, jk) - zhlc(ji, jj))
            zwlc = zind * rn_lc * zus * SIN(rpi * pdepw(ji, jj, jk) / zhlc(ji, jj))
            en(ji, jj, jk) = en(ji, jj, jk) + rdt * MAX(0., 1._wp - 4. * fr_i(ji, jj)) * (zwlc * zwlc * zwlc) / zhlc(ji, jj) * wmask(ji, jj, jk) * tmask(ji, jj, 1)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (nn_pdl == 1) THEN
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zri = MAX(rn2b(ji, jj, jk), 0._wp) * p_avm(ji, jj, jk) / (p_sh2(ji, jj, jk) + rn_bshear)
            apdlr(ji, jj, jk) = MAX(0.1_wp, ri_cri / MAX(ri_cri, zri))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zcof = zfact1 * tmask(ji, jj, jk)
          zzd_up = zcof * MAX(p_avm(ji, jj, jk + 1) + p_avm(ji, jj, jk), 2.E-5_wp) / (p_e3t(ji, jj, jk) * p_e3w(ji, jj, jk))
          zzd_lw = zcof * MAX(p_avm(ji, jj, jk) + p_avm(ji, jj, jk - 1), 2.E-5_wp) / (p_e3t(ji, jj, jk - 1) * p_e3w(ji, jj, jk))
          zd_up(ji, jj, jk) = zzd_up
          zd_lw(ji, jj, jk) = zzd_lw
          zdiag(ji, jj, jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji, jj, jk) * wmask(ji, jj, jk)
          en(ji, jj, jk) = en(ji, jj, jk) + rdt * (p_sh2(ji, jj, jk) - p_avt(ji, jj, jk) * rn2(ji, jj, jk) + zfact3 * dissl(ji, jj, jk) * en(ji, jj, jk)) * wmask(ji, jj, jk)
        END DO
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zdiag(ji, jj, jk) = zdiag(ji, jj, jk) - zd_lw(ji, jj, jk) * zd_up(ji, jj, jk - 1) / zdiag(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zd_lw(ji, jj, 2) = en(ji, jj, 2) - zd_lw(ji, jj, 2) * en(ji, jj, 1)
      END DO
    END DO
    DO jk = 3, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zd_lw(ji, jj, jk) = en(ji, jj, jk) - zd_lw(ji, jj, jk) / zdiag(ji, jj, jk - 1) * zd_lw(ji, jj, jk - 1)
        END DO
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        en(ji, jj, jpkm1) = zd_lw(ji, jj, jpkm1) / zdiag(ji, jj, jpkm1)
      END DO
    END DO
    DO jk = jpk - 2, 2, - 1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          en(ji, jj, jk) = (zd_lw(ji, jj, jk) - zd_up(ji, jj, jk) * en(ji, jj, jk + 1)) / zdiag(ji, jj, jk)
        END DO
      END DO
    END DO
    DO jk = 2, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          en(ji, jj, jk) = MAX(en(ji, jj, jk), rn_emin) * wmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (nn_etau == 1) THEN
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            en(ji, jj, jk) = en(ji, jj, jk) + rn_efr * en(ji, jj, 1) * EXP(- pdepw(ji, jj, jk) / htau(ji, jj)) * MAX(0., 1._wp - rn_eice * fr_i(ji, jj)) * wmask(ji, jj, jk) * tmask(ji, jj, 1)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    ELSE IF (nn_etau == 2) THEN
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          jk = nmln(ji, jj)
          en(ji, jj, jk) = en(ji, jj, jk) + rn_efr * en(ji, jj, 1) * EXP(- pdepw(ji, jj, jk) / htau(ji, jj)) * MAX(0., 1._wp - rn_eice * fr_i(ji, jj)) * wmask(ji, jj, jk) * tmask(ji, jj, 1)
        END DO
      END DO
      !$ACC END KERNELS
    ELSE IF (nn_etau == 3) THEN
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            ztx2 = utau(ji - 1, jj) + utau(ji, jj)
            zty2 = vtau(ji, jj - 1) + vtau(ji, jj)
            ztau = 0.5_wp * SQRT(ztx2 * ztx2 + zty2 * zty2) * tmask(ji, jj, 1)
            zdif = taum(ji, jj) - ztau
            zdif = rhftau_scl * MAX(0._wp, zdif + rhftau_add)
            en(ji, jj, jk) = en(ji, jj, jk) + zbbrau * zdif * EXP(- pdepw(ji, jj, jk) / htau(ji, jj)) * MAX(0., 1._wp - rn_eice * fr_i(ji, jj)) * wmask(ji, jj, jk) * tmask(ji, jj, 1)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
  END SUBROUTINE tke_tke
  SUBROUTINE tke_avn(pdepw, p_e3t, p_e3w, p_avm, p_avt)
    USE zdf_oce, ONLY: en, avtb, avmb, avtb_2d
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: pdepw
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(IN   ) :: p_e3t, p_e3w
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(  OUT) :: p_avm, p_avt
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zrn2, zraug, zcoef, zav
    REAL(KIND = wp) :: zdku, zdkv, zsqen
    REAL(KIND = wp) :: zemxl, zemlm, zemlp
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zmxlm, zmxld
    !$ACC KERNELS
    zmxlm(:, :, :) = rmxl_min
    zmxld(:, :, :) = rmxl_min
    !$ACC END KERNELS
    IF (ln_mxl0) THEN
      !$ACC KERNELS
      zraug = vkarmn * 2.E5_wp / (rau0 * grav)
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zmxlm(ji, jj, 1) = MAX(rn_mxl0, zraug * taum(ji, jj) * tmask(ji, jj, 1))
        END DO
      END DO
      !$ACC END KERNELS
    ELSE
      !$ACC KERNELS
      zmxlm(:, :, 1) = rn_mxl0
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zrn2 = MAX(rn2(ji, jj, jk), rsmall)
          zmxlm(ji, jj, jk) = MAX(rmxl_min, SQRT(2._wp * en(ji, jj, jk) / zrn2))
        END DO
      END DO
    END DO
    zmxld(:, :, 1) = zmxlm(:, :, 1)
    zmxld(:, :, jpk) = rmxl_min
    !$ACC END KERNELS
    SELECT CASE (nn_mxl)
    CASE (0)
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zemxl = MIN(pdepw(ji, jj, jk) - pdepw(ji, jj, mikt(ji, jj)), zmxlm(ji, jj, jk), pdepw(ji, jj, mbkt(ji, jj) + 1) - pdepw(ji, jj, jk))
            zmxlm(ji, jj, jk) = zemxl * wmask(ji, jj, jk) + MIN(zmxlm(ji, jj, jk), p_e3w(ji, jj, jk)) * (1 - wmask(ji, jj, jk))
            zmxld(ji, jj, jk) = zemxl * wmask(ji, jj, jk) + MIN(zmxlm(ji, jj, jk), p_e3w(ji, jj, jk)) * (1 - wmask(ji, jj, jk))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (1)
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zemxl = MIN(p_e3w(ji, jj, jk), zmxlm(ji, jj, jk))
            zmxlm(ji, jj, jk) = zemxl
            zmxld(ji, jj, jk) = zemxl
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zmxlm(ji, jj, jk) = MIN(zmxlm(ji, jj, jk - 1) + p_e3t(ji, jj, jk - 1), zmxlm(ji, jj, jk))
          END DO
        END DO
      END DO
      DO jk = jpkm1, 2, - 1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zemxl = MIN(zmxlm(ji, jj, jk + 1) + p_e3t(ji, jj, jk + 1), zmxlm(ji, jj, jk))
            zmxlm(ji, jj, jk) = zemxl
            zmxld(ji, jj, jk) = zemxl
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (3)
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zmxld(ji, jj, jk) = MIN(zmxld(ji, jj, jk - 1) + p_e3t(ji, jj, jk - 1), zmxlm(ji, jj, jk))
          END DO
        END DO
      END DO
      DO jk = jpkm1, 2, - 1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zmxlm(ji, jj, jk) = MIN(zmxlm(ji, jj, jk + 1) + p_e3t(ji, jj, jk + 1), zmxlm(ji, jj, jk))
          END DO
        END DO
      END DO
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zemlm = MIN(zmxld(ji, jj, jk), zmxlm(ji, jj, jk))
            zemlp = SQRT(zmxld(ji, jj, jk) * zmxlm(ji, jj, jk))
            zmxlm(ji, jj, jk) = zemlm
            zmxld(ji, jj, jk) = zemlp
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zsqen = SQRT(en(ji, jj, jk))
          zav = rn_ediff * zmxlm(ji, jj, jk) * zsqen
          p_avm(ji, jj, jk) = MAX(zav, avmb(jk)) * wmask(ji, jj, jk)
          p_avt(ji, jj, jk) = MAX(zav, avtb_2d(ji, jj) * avtb(jk)) * wmask(ji, jj, jk)
          dissl(ji, jj, jk) = zsqen / zmxld(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (nn_pdl == 1) THEN
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            p_avt(ji, jj, jk) = MAX(apdlr(ji, jj, jk) * p_avt(ji, jj, jk), avtb_2d(ji, jj) * avtb(jk)) * tmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (ln_ctl) THEN
      CALL prt_ctl(tab3d_1 = en, clinfo1 = ' tke  - e: ', tab3d_2 = p_avt, clinfo2 = ' t: ', kdim = jpk)
      CALL prt_ctl(tab3d_1 = p_avm, clinfo1 = ' tke  - m: ', kdim = jpk)
    END IF
  END SUBROUTINE tke_avn
  SUBROUTINE zdf_tke_init
    USE zdf_oce, ONLY: ln_zdfiwm
    INTEGER :: ji, jj, jk
    INTEGER :: ios
    NAMELIST /namzdf_tke/ rn_ediff, rn_ediss, rn_ebb, rn_emin, rn_emin0, rn_bshear, nn_mxl, ln_mxl0, rn_mxl0, nn_pdl, ln_drg, ln_lc, rn_lc, nn_etau, nn_htau, rn_efr, rn_eice
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_tke in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namzdf_tke in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namzdf_tke)
    ri_cri = 2._wp / (2._wp + rn_ediss / rn_ediff)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'zdf_tke_init : tke turbulent closure scheme - initialisation'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namzdf_tke : set tke mixing parameters'
      WRITE(numout, FMT = *) '      coef. to compute avt                        rn_ediff  = ', rn_ediff
      WRITE(numout, FMT = *) '      Kolmogoroff dissipation coef.               rn_ediss  = ', rn_ediss
      WRITE(numout, FMT = *) '      tke surface input coef.                     rn_ebb    = ', rn_ebb
      WRITE(numout, FMT = *) '      minimum value of tke                        rn_emin   = ', rn_emin
      WRITE(numout, FMT = *) '      surface minimum value of tke                rn_emin0  = ', rn_emin0
      WRITE(numout, FMT = *) '      prandl number flag                          nn_pdl    = ', nn_pdl
      WRITE(numout, FMT = *) '      background shear (>0)                       rn_bshear = ', rn_bshear
      WRITE(numout, FMT = *) '      mixing length type                          nn_mxl    = ', nn_mxl
      WRITE(numout, FMT = *) '         surface mixing length = F(stress) or not    ln_mxl0   = ', ln_mxl0
      WRITE(numout, FMT = *) '         surface  mixing length minimum value        rn_mxl0   = ', rn_mxl0
      WRITE(numout, FMT = *) '      top/bottom friction forcing flag            ln_drg    = ', ln_drg
      WRITE(numout, FMT = *) '      Langmuir cells parametrization              ln_lc     = ', ln_lc
      WRITE(numout, FMT = *) '         coef to compute vertical velocity of LC     rn_lc  = ', rn_lc
      WRITE(numout, FMT = *) '      test param. to add tke induced by wind      nn_etau   = ', nn_etau
      WRITE(numout, FMT = *) '          type of tke penetration profile            nn_htau   = ', nn_htau
      WRITE(numout, FMT = *) '          fraction of TKE that penetrates            rn_efr    = ', rn_efr
      WRITE(numout, FMT = *) '          below sea-ice:  =0 ON                      rn_eice   = ', rn_eice
      WRITE(numout, FMT = *) '          =4 OFF when ice fraction > 1/4   '
      IF (ln_drg) THEN
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '   Namelist namdrg_top/_bot:   used values:'
        WRITE(numout, FMT = *) '      top    ocean cavity roughness (m)          rn_z0(_top)= ', r_z0_top
        WRITE(numout, FMT = *) '      Bottom seafloor     roughness (m)          rn_z0(_bot)= ', r_z0_bot
      END IF
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) '   ==>>>   critical Richardson nb with your parameters  ri_cri = ', ri_cri
      WRITE(numout, FMT = *)
    END IF
    IF (ln_zdfiwm) THEN
      rn_emin = 1.E-10_wp
      rmxl_min = 1.E-03_wp
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   Internal wave-driven mixing case:   force   rn_emin = 1.e-10 and rmxl_min = 1.e-3'
    ELSE
      rmxl_min = 1.E-6_wp / (rn_ediff * SQRT(rn_emin))
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   minimum mixing length with your parameters rmxl_min = ', rmxl_min
    END IF
    IF (zdf_tke_alloc() /= 0) CALL ctl_stop('STOP', 'zdf_tke_init : unable to allocate arrays')
    IF (nn_mxl < 0 .OR. nn_mxl > 3) CALL ctl_stop('bad flag: nn_mxl is  0, 1 or 2 ')
    IF (nn_pdl < 0 .OR. nn_pdl > 1) CALL ctl_stop('bad flag: nn_pdl is  0 or 1    ')
    IF ((nn_htau < 0 .OR. nn_htau > 1) .AND. nn_htau .NE. 4) CALL ctl_stop('bad flag: nn_htau is 0, 1 or 4 ')
    IF (nn_etau == 3 .AND. .NOT. ln_cpl) CALL ctl_stop('nn_etau == 3 : HF taum only known in coupled mode')
    IF (ln_mxl0) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   use a surface mixing length = F(stress) :   set rn_mxl0 = rmxl_min'
      rn_mxl0 = rmxl_min
    END IF
    IF (nn_etau == 2) CALL zdf_mxl(nit000)
    IF (nn_etau /= 0) THEN
      SELECT CASE (nn_htau)
      CASE (0)
        !$ACC KERNELS
        htau(:, :) = 10._wp
        !$ACC END KERNELS
      CASE (1)
        !$ACC KERNELS
        htau(:, :) = MAX(0.5_wp, MIN(30._wp, 45._wp * ABS(SIN(rpi / 180._wp * gphit(:, :)))))
        !$ACC END KERNELS
      CASE (4)
        !$ACC KERNELS
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            IF (gphit(ji, jj) <= 0._wp) THEN
              htau(ji, jj) = MAX(0.5_wp, MIN(30._wp, 45._wp * ABS(SIN(rpi / 180._wp * gphit(ji, jj)))))
            ELSE
              htau(ji, jj) = MAX(0.5_wp, MIN(10._wp, 45._wp * ABS(SIN(rpi / 180._wp * gphit(ji, jj)))))
            END IF
          END DO
        END DO
        !$ACC END KERNELS
      END SELECT
    END IF
    CALL tke_rst(nit000, 'READ')
    IF (lwxios) THEN
      CALL iom_set_rstw_var_active('en')
      CALL iom_set_rstw_var_active('avt_k')
      CALL iom_set_rstw_var_active('avm_k')
      CALL iom_set_rstw_var_active('dissl')
    END IF
  END SUBROUTINE zdf_tke_init
  SUBROUTINE tke_rst(kt, cdrw)
    USE zdf_oce, ONLY: en, avt_k, avm_k
    INTEGER, INTENT(IN) :: kt
    CHARACTER(LEN = *), INTENT(IN) :: cdrw
    INTEGER :: jit, jk
    INTEGER :: id1, id2, id3, id4
    IF (TRIM(cdrw) == 'READ') THEN
      IF (ln_rstart) THEN
        id1 = iom_varid(numror, 'en', ldstop = .FALSE.)
        id2 = iom_varid(numror, 'avt_k', ldstop = .FALSE.)
        id3 = iom_varid(numror, 'avm_k', ldstop = .FALSE.)
        id4 = iom_varid(numror, 'dissl', ldstop = .FALSE.)
        IF (MIN(id1, id2, id3, id4) > 0) THEN
          CALL iom_get(numror, jpdom_autoglo, 'en', en, ldxios = lrxios)
          CALL iom_get(numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios)
          CALL iom_get(numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios)
          CALL iom_get(numror, jpdom_autoglo, 'dissl', dissl, ldxios = lrxios)
        ELSE
          IF (lwp) WRITE(numout, FMT = *)
          IF (lwp) WRITE(numout, FMT = *) '   ==>>>   previous run without TKE scheme, set en to background values'
          !$ACC KERNELS
          en(:, :, :) = rn_emin * wmask(:, :, :)
          dissl(:, :, :) = 1.E-12_wp
          !$ACC END KERNELS
        END IF
      ELSE
        IF (lwp) WRITE(numout, FMT = *)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   start from rest: set en to the background value'
        !$ACC KERNELS
        en(:, :, :) = rn_emin * wmask(:, :, :)
        dissl(:, :, :) = 1.E-12_wp
        !$ACC END KERNELS
      END IF
    ELSE IF (TRIM(cdrw) == 'WRITE') THEN
      IF (lwp) WRITE(numout, FMT = *) '---- tke_rst ----'
      IF (lwxios) CALL iom_swap(cwxios_context)
      CALL iom_rstput(kt, nitrst, numrow, 'en', en, ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios)
      IF (lwxios) CALL iom_swap(cxios_context)
    END IF
  END SUBROUTINE tke_rst
END MODULE zdftke


        PARAMETER       ( MXMN = 8 )
        PARAMETER       ( MXLV = 220 )
        PARAMETER       ( NVAR = 17 )
        PARAMETER       ( NSTR = 4 )

        REAL*8          r8arr ( MXMN, MXLV ), r8arr2(MXMN, MXLV ),
     +                  r8arr3 ( MXMN, MXLV ), r8arr4(MXMN, MXLV )

        parameter (iu=9, iou=10)

        real pr,tt,td
        integer xht, nlev, i, iargc, n, minu, k
        real xpr, xu, xv
        real temp, v, zx, d
        real lat, lon
        real xt, xtd
        character*30 fin, fout
        character*10  date_tag, date
        character*6 dname
        character argv*300, minute*2, M11*2, mins*2
        character*12 ilev
        character*12 M10,M1,M2,M3,M4,M5,M6
        real wlon, elon, slat, nlat

        CHARACTER     csubset*8, inf*200, outstg*200
        CHARACTER*80  ostr(NSTR)
        INTEGER       y, z, idate, iflag

        ostr(1)='SAID RPID'
        ostr(2)='SIDP SWCM YEAR MNTH DAYS'
        ostr(3)='HOUR MINU CLAT CLON'
        ostr(4)='TMDBST PRLC WDIR WSPD'

C*-----------------------------------------------------------------------
c*    Read the command-line arguments
c*
        n = iargc()
        IF (n .GE. 2) THEN
          call getarg( 1, argv )
          inf=argv
          call getarg(2,argv)
          date_tag=argv
          IF (n .eq. 6) THEN  ! User-specified lat/lon boundaries
            call getarg(3,argv)
            read(argv,*) wlon
            call getarg(4,argv)
            read(argv,*) elon
            call getarg(5,argv)
            read(argv,*) slat
            call getarg(6,argv)
            read(argv,*) nlat
            write(*,*) 'Lon/lat boundaries: ',wlon,elon,slat,nlat
          ELSE  ! Default lon/lat boundaries
            slat = -90.
            nlat = 90.
            wlon = -180.
            elon = 180.
          END IF
        ELSE
          write(*,*) 'Usage: bufr_sat2ob.x gdas.satwnd.t<HH>z.
     +<YYYYMMDD>.bufr <YYYYMMDDHH> west_lon east_lon
     +south_lat north_lat'
          STOP
        END IF

C*-----------------------------------------------------------------------

C*      Open the BUFR messages file
        OPEN (UNIT=11, FILE=inf, form='unformatted')

c*        write(*,*) 'Date_tag (YYYYMMDDHH) : '
c*        read(*,fmt='(a10)') date_tag

        dname=' SATOB'
        fout= "Satob"//date_tag//'.obs'

C*      Open output file
        open(iou,file=fout,status='unknown',form='formatted')
        write(iou,fmt='(a10)') date_tag

        iflag=0
        nlev=1
        dumm=99999.9

        isurf = 0
        ibogus = 0
        ter = dumm
        dslp = dumm
        date='MMMMMMMMMM'
        mins='MM'
        pr=dumm
        zx=dumm
        tt=dumm
        td=dumm
        d=dumm
        v=dumm

C*      Identify BUFR file to the BUFRLIB software.  DX BUFR tables
C*      are embedded within the first few messages of the BUFR file
C*      itself, thus we logical unit for the BUFR tables file is the
C*      same as the BUFR file itself.

        CALL OPENBF  (11, 'IN', 11)

C*      Specify that we would like IDATE values returned using 10 digits
C*      (i.e. YYYYMMDDHHMM ).

        CALL DATELEN  ( 10 )

C*-----------------------------------------------------------------------
        DO WHILE  ( .true. )

C*          Read the next BUFR message.

           call readns(11,csubset,idate,ierr)
c            write(*,*)' idate: ',idate,'  ',csubset
            IF  ( ierr .eq.  -1 )  THEN
                write(*,*) '[bufr_sat2ob]....all records read, Exit'
                CALL CLOSBF  ( 11 )
                goto 2000
            END IF

C*            At this point, we have a data subset within the
C*            internal arrays of BUFRLIB, and we can now begin
C*            reading actual data values:

              CALL UFBINT(11, r8arr, MXMN, MXLV, nlv, ostr(1))
              CALL UFBINT(11, r8arr2, MXMN, MXLV, nlv, ostr(2))
              CALL UFBINT(11, r8arr3, MXMN, MXLV, nlv, ostr(3))
              CALL UFBINT(11, r8arr4, MXMN, MXLV, nlv, ostr(4))

            minu=int(r8arr3(2,1))
            write (unit=minute, FMT='(I2)') minu

            DO k=1,2
               IF ( minute (k:k) .eq. ' ') THEN
                 minute (k:k) = '0'
               ENDIF
            ENDDO

            DO z = 1, nlv
              WRITE (UNIT=outstg, FMT='(I10,1x,A8,
     +          3(1X,F5.1),1X,A8,1X,F5.1,
     +          1X,F4.1,1X,F6.1,4(1x,F4.1),2(1X,F7.2),1X,F6.2,
     +          1X,F7.1,1X,F5.1,1x,F6.2)') idate,csubset,
     +          (r8arr(i,z), i = 1,2),(r8arr2(i,z), i = 1,5),
     +          (r8arr3(i,z), i = 1,4),(r8arr4(i,z), i = 1,4)
              DO y = 1,200
               IF ( outstg (y:y) .eq. '*') THEN
                 outstg (y:y) = 'm'
               ENDIF
              ENDDO

              read(outstg,21,end=2000) M10,M1,M2,M3,M4,M5,M6
              read(minute,22) M11

21            format(A10,64X,A6,1X,A7,1X,A6,1X,A7,1X,A5,2X,A5)
22            format(A2)

C*-----------------------------------------------------------------------
c         Prepare output

              CALL READMval(M1,lat)
              CALL READMval(M2,lon)
              CALL READMval(M3,tt)
              CALL READMval(M4,pr)
              CALL READMval(M5,d)
              CALL READMval(M6,v)

              date=M10
              mins=M11
              if(pr.ne.0 .and. pr<99999 ) then
                pr=pr/100
              end if

c        write to output file
              if (iflag.eq.0) then
                write(iou,fmt='(a10)') date_tag
                iflag=1
              endif
              if(slat<=lat .and. nlat>=lat .and. wlon<=lon .and.
     &        elon>=lon) then
                 write(iou,111)isurf,dname,dname,date,mins,
     &                         lat,lon,ter,dslp,nlev,ibogus
                 write(iou,112)pr,zx,tt,td,d,v
              endif
111      format(i1,2(1x,a6),1x,a10,a2,4(f7.1,1x),i3,1x,i1)
112      format(6(f7.1,1x))

            END DO
        END DO

C*-----------------------------------------------------------------------

2000    stop 99999

        END

C*-----------------------------------------------------------------------

      SUBROUTINE READMval(M1,fl)
           character*8 M1
           dumm=99999.9
           if(M1(1:1) ==  'm') then
               fl = dumm
           else
               read(M1,*)fl
           endif

       RETURN
         END


IMPLICIT DOUBLE PRECISION (A-H, O-Z)
parameter(ns = 200, r = 1.987E-3, pi = 3.141592654)
DIMENSION sig(ns)
DIMENSION T(0:ns), DTIM(0:ns), age(0:ns)
dimension terrage(0:ns), clage(0:ns), errclage(0:ns)
common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
        xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe

CHARACTER*9  TAB1, sname*50, yes*3
yes = 'no'
TAB1 = CHAR(09)

5    open(unit = 31, file = 'files.cl', status = 'old')

1     read(31, '(a50)') sname
kn = name(sname)
print *, sname(1:kn)
print *, kn

open(unit = 17, file = sname(1:kn) // '.in', status = 'old')
open(unit = 16, file = 'arr.smp')
open(unit = 19, file = 'log.smp')
open(unit = 11, file = 'temstep.in')
open(unit = 21, file = 'age-sd.smp')
open(unit = 22, file = 'age-cl.smp')
open(unit = 23, file = 'fj.in')
open(unit = 24, file = 'sig.in')
open(unit = 25, file = 'age.in')
open(unit = 26, file = sname(1:kn) // '_a39.in')
open(unit = 30, file = sname(1:kn) // '_ener.dat')
print *, 'files opened'

120    format(1x, I3)
n = 0
30    n = n + 1
read(17, *, END = 35)nstp, t(n), dtim(n), a39(n), sig39(n), f(n), age(n)&
        , sig(n), terrage(n), clage(n), errclage(n)
t(n) = t(n) + 273.
f(n) = f(n) / 100.d0
age(n) = age(n)
sig(n) = sig(n)
telab(n) = t(n)

goto 30
35    write(11, 120)n - 1
if(f(n - 1).eq.1.0)f(n - 1) = 0.999999
do 20 j = 1, n - 1
    write(23, *)f(j)
    write(11, *)t(j)
    write(11, *)dtim(j)
    dtim(j) = 60. * dtim(j)
20    tilab(j) = dtim(j)

do 80 k = 1, n - 1
    write (21, *)f(k - 1) * 100., age(k) + sig(k)
    write (21, *)f(k) * 100., age(k) + sig(k)
    write (22, *)f(k - 1) * 100., clage(k) + errclage(k)
    write (22, *)f(k) * 100., clage(k) + errclage(k)
    write (25, *)f(k) * 100., clage(k)
    write (24, *)errclage(k)
    write (26, *)a39(k), sig39(k)
80    continue

nt = n - 1
do 90 k = 1, n - 1
    write (21, *)f(nt - k + 1) * 100., age(nt - k + 1) - sig(nt - k + 1)
    write (21, *)f(nt - k) * 100., age(nt - k + 1) - sig(nt - k + 1)
    write (22, *)f(nt - k + 1) * 100., clage(nt - k + 1) - errclage(nt - k + 1)
    write (22, *)f(nt - k) * 100., clage(nt - k + 1) - errclage(nt - k + 1)
90    continue
write (21, *)f(1) * 100., age(2) + sig(2)
write (22, *)f(1) * 100., clage(2) + errclage(2)

call arr(nt, yes)
100    format(1x, '&
        &')
n=0
close(17)
close(16)
close(19)
close(11)
close(21)
close(22)
close(23)
close(24)
close(25)
close(30)

!goto 1
501    stop
END

function name(sname)
    character sname*50
    do 10 j = 1, 50
        if(sname(j:j).eq.' ')then
            if(j.eq.1)stop 'name starts with empty space'
            name = j - 1
            return
        endif
        name = 50
    10    continue
    return
end

!	t(n) = temperature (C)
!  	a2 = 40Ar/39Ar
!	a37(j) = 37Ar/39Ar
!	a4 = 36Ar/39Ar
!	a5 = mol 39Ar
!	f39(n) = fraction of 39Ar
!	a6 = % 40Ar*
!	a7 = 40Ar*/39Ark
!	age(n)= Apparent age in yr
!	sig(n)= sigma uncertainty of age in yr
!	time(n) = time in minutes
!	a8 = 39Ar/40Ar
!	a9 = sigma uncertainty 39Ar/40Ar
!	a10= 36Ar/40Ar
!	a11= sigma uncertainty of 36Ar/40Ar
!	Tinv= Inverse of temperature
!	a13= sigma  uncertainty of Temperature
!	xlog= log(D/r**2)
!	a15= sigma uncertainty of log(D/r**2)
!	SUBROUTINE ARR.F
! **********************************************************************
subroutine arr(nt, yes)
    implicit double precision (a-h, o-z)
    parameter(nca = 20, ns = 200, r = 1.987E-3, pi = 3.141592654)
    parameter(ee = 0.4342944879, ngauss = 10)
    dimension wt(ns)
    common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
            xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe
    common /int/ ni, imp, nimax, ke
    character  tab1*9, yes*1
    tab1 = char(09)
    ni = nt
    nloop = 1
    f(0) = 0.
    b = 8.
    imp = 2.
    acut = 0.5
    dchmin = 0.01
    ncons = 0.
    nimax = ni
    do 10 nt = 1, ni
        if(ni.eq.nimax.and.telab(nt).gt.1373)nimax = nt - 1
    10    continue
    call diff(ord, E, wt, xro, yes)
    !      call weight(wf)
    write(*, 101) 'E=', e, ' +- ', sige, '     Ordinate=', ord, ' +-', sigo
    write(30, *)
    write(30, 101)'E=', e, ' +- ', sige, '     Ordinate=', ord, ' +-', sigo

    close(30)

    return
    100 format(G20.8)
    101 format(1x, A3, f8.4, A5, f8.4, A14, f8.4, A5, f8.4)
    102 format(A50)
    105 format(f12.8)
    110 format(1X, 5(F12.8, A1))
    115 format(1X, I4, 3x, f9.5, 7x, f9.5)
    116 format(1x, A10, A1, 8(f8.5, 1x), i2)
    120 format(I7)
    130 format(6x, 'tinv', 8x, 'Log(D/r2)', 7x, 'f(k)*100', 8x, &
            'Log(r/ro)', 8x, '39Ar-av')
    140 format(1x, 'domain #', 10x, 'volume fraction', 15x, 'domain size')
    150 format(1x, '&
    &')
    160 format(A7)
    170 format(1x, i4, 4(a1, g20.8))
    180 format(a10, 4(a1, f7.4), a1, i2, 2(g14.8), 2i6)
end

!       SUBROUTINE DIFF.F
!	SUBROUTINE PARAM.F
!  	SUBROUTINES FIT, GSER, and GCF  - FUNCTIONS GAMMQ and GAMMLN

subroutine diff(ord, E, wt, xro, yes)
    implicit double precision (a-h, o-z)
    parameter(ns = 200, r = 1.987E-3, pi = 3.141592654, ee = 0.4342944879)
    dimension tinv(ns), wt(ns)
    common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
            xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe
    common /int/ ni, imp, nimax, ke
    character tab1*9, yes*1
    tab1 = char(09)
    xlogr(0) = 0.
    !     CALCULATION OF LOG(D/R^2)
    do 10 k = 1, ni
        if (f(k).le.acut) then
            xlogr(k) = pi * (f(k) / 4.)**2
        else
            xlogr(k) = -dlog(pi**2 / b * (1. - f(k))) / pi**2
        endif
    10    continue
    sumwt = 0.
    nix = ni
    call errcal(wt, sumwt)
    do 20 k = 1, ni
        if(nix.eq.ni.and.telab(k).gt.1373)nix = k - 1
        xlogd(k) = dlog10((xlogr(k) - xlogr(k - 1)) / tilab(k) * imp**2)
        tinv(k) = 1. / telab(k) * 10000.
        write(16, 110)tinv(k), tab1, xlogd(k), tab1, wt(k)
    20    continue

    call param(tinv, wt, e, ord, yes)
    slop = e * ee / (r * 10000)
    xro = (ord - slop * tinv(nix) - xlogd(nix)) / 2. * (1. + (1. - f(nix)) / 2.)
    do 30 k = 1, ni
        xlogr(k) = (ord - slop * tinv(k) - xlogd(k)) / 2.
        write(19, 110)f(k - 1) * 100., tab1, xlogr(k)
        write(19, 110)f(k) * 100., tab1, xlogr(k)
    30    continue
    return
    110   format(1X, 5(F12.8, A1))
    100    format(1x, i5, 5(f16.8))
end

!     SUBROUTINE PARAM.F
subroutine param(tinv, wt, e, ord, yes)
    implicit double precision (a-h, o-z)
    parameter(ns = 200, r = 1.987E-3, pi = 3.141592654, ee = 0.4342944879&
            , nstop = 20, mwt = 1, dtp = 5.d0)
    dimension tinv(ns), wt(ns), y(ns), alog(ns), x1(ns), y1(0:ns), wty(ns)&
            , wtx(ns)
    dimension tinvaux(nstop + 5), xlogdaux(nstop + 5), wtaux(nstop + 5), &
            telabaux(nstop + 5), prm(nstop)
    common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
            xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe
    common /int/ ni, imp, nimax, ke
    character tab1*9, yes*1, yesp*1, yestemp*1
    tab1 = char(09)
    nst = nstop
    y(3) = 0.
    if(ni.lt.nstop) then
        nst = ni
    endif

    ki = 0
    yestemp = 'y'
    if(yestemp.ne.'y')then
        !      Print *,'Do you want to exclude some points'
        !      Print *, 'from E calculation (yes/no)?'
        !	read *,yesp
        yesp = 'no'
        if (yesp.eq.'y')then
            print *, 'How many points do you want to remove?'
            read *, np
            do 4 k = 1, np
                !	     Print *, 'Enter the step # of the point(s) to be removed'
                read *, prm(k)
            4        continue
            k0 = 1
            k1 = 1
            k2 = 1
            5     continue
            if (prm(k0).eq.k1)then
                k1 = k1 + 1
                k0 = k0 + 1
                if(k1.le.nst)goto 5
            endif
            tinvaux(k2) = tinv(k1)
            xlogdaux(k2) = xlogd(k1)
            wtaux(k2) = wt(k1)
            telabaux(k2) = telab(k1)
            k2 = k2 + 1
            k1 = k1 + 1
            if(k1.le.nst)goto 5
            nst = k2 - 1
            goto 6
        endif
    endif

    15    qmaxk = 0.
    qmax = 1.
    sx1 = 0.
    do 3 k = 1, nst
        tinvaux(k) = tinv(k)
        xlogdaux(k) = xlogd(k)
        wtaux(k) = wt(k)
        telabaux(k) = telab(k)
    3        continue

    6      do 12 j = 1, 3
        x1(j) = tinvaux(ki + j)
        sx1 = sx1 + x1(j)
        y1(j) = xlogdaux(ki + j)
        wty(j) = wtaux(ki + j)
        wtx(j) = 10000.d0 * dtp / telabaux(ki + j)**2
    12    continue
    do 10 k = 4, nst
        x1(k) = tinvaux(ki + k)
        sx1 = sx1 + x1(k)
        y1(k) = xlogdaux(ki + k)
        wty(k) = wtaux(ki + k)
        wtx(k) = 10000.d0 * dtp / telabaux(ki + k)**2
        if(x1(k).eq.sx1 / k)goto 10
        ncont = 1
        do 16 j = 2, k
            ks = 0
            do 14 j1 = 1, j - 1
                if(x1(j).eq.x1(j1))ks = 1
            14       continue
            if(ks.eq.0)ncont = ncont + 1
        16      continue
        call fit(x1, y1, k, wtx, wty, a, bf, siga, sigb, chi2, q)
        if(q / qmax.lt.1.e-10)goto 24
        y(k) = -r * bf * 10000. / ee
        alog(k) = a
        sige1 = r * sigb * 10000. / ee
        qs = k * q
        write(30, 100)k, y(k), sige1, alog(k), siga, qs
        if(qs.gt.qmaxk.and.ncont.ge.3)then
            ke = k
            if(qs.gt.qmaxk)qmaxk = qs
            qmax = q
            chisqe = chi2
            sige = sigb * r * 10000.d0 / ee
            sigo = siga
            e = y(k)
            ord = alog(k)
        endif
    10    continue
    24    continue
    if(ki.eq.0.and.qmax.lt.0.05)then
        ki = 1
        goto 15
    endif
    100   format(1x, i5, 5(f14.6), 2g20.8)
    110   format(1X, 5(F12.8, A1))
    return
end

subroutine fit(x, y, ndata, sigx, sigy, a, b, siga, sigb, chi2, q)
    implicit double precision (a-h, o-z)
    parameter(nd = 20, imax = 20, xerr = 1.d-3)
    dimension x(ndata), y(0:ndata), sigx(ndata), sigy(ndata), wt(nd)
    r = 0.
    b = -1.
    iter = 0
    1     sx = 0.
    sy = 0.
    st2 = 0.
    st3 = 0.
    ss = 0.
    b0 = b
    do 11 i = 1, ndata
        wt(i) = 1. / (sigy(i)**2 + b**2 * sigx(i)**2 - 2.d0 * r * sigx(i) * sigy(i))
        ss = ss + wt(i)
        sx = sx + x(i) * wt(i)
        sy = sy + y(i) * wt(i)
    11    continue
    sxoss = sx / ss
    syoss = sy / ss
    do 13 i = 1, ndata
        t1 = (x(i) - sxoss) * sigy(i)**2
        t2 = (y(i) - syoss) * sigx(i)**2 * b
        t3 = sigx(i) * sigy(i) * r
        st2 = st2 + wt(i)**2 * (y(i) - syoss) * (t1 + t2 - t3 * (y(i) - syoss))
        st3 = st3 + wt(i)**2 * (x(i) - sxoss) * (t1 + t2 - b * t3 * (x(i) - sxoss))
    13    continue
    b = st2 / st3
    iter = iter + 1
    if(iter.gt.imax)stop 'FIT2: TOO MANY ITERATIONS'
    if(dabs(b0 - b).gt.xerr)goto 1
    a = (syoss - sxoss * b)
    sgt1 = 0.
    sgt2 = 0.
    do 14 i = 1, ndata
        sgt1 = sgt1 + wt(i) * (x(i) - sxoss)**2
        sgt2 = sgt2 + wt(i) * x(i)**2
    14    continue
    sigb = dsqrt(1. / sgt1)
    siga = sigb * dsqrt(sgt2 / ss)
    chi2 = 0.
    do 16 i = 1, ndata
        chi2 = chi2 + wt(i) * (y(i) - a - b * x(i))**2
    16      continue
    q = gammq(0.5d0 * (ndata - 2), 0.5d0 * chi2)
    return
end

subroutine weight(wf)
    implicit double precision (a-h, o-z)
    parameter(ns = 200)
    dimension wf(ns)
    common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
            xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe
    common /int/ ni, imp, nimax, ke
    sumwt = 0
    do 20 k = 1, ni
        wf(k) = 1. / dsqrt(f(k) - f(k - 1))
        sumwt = sumwt + wf(k)
    20    continue
    do 25 k = 1, ni
        wf(k) = wf(k) / sumwt
    25    continue
    return
end

subroutine errcal(wt, swt)
    implicit double precision (a-h, o-z)
    parameter(ns = 200, r = 1.987E-3, pi = 3.141592654, ee = 0.4342944819, &
            sigt0 = 90.d0, a0 = -0.19354d0, a1 = -0.62946d0, &
            a2 = 0.13505d0, a3 = -0.01528d0)
    dimension sigzit(0:ns), wt(ns), sigf(0:ns), siga(0:ns)
    dimension sigsm(ns), f1(0:ns)
    common /var/ f(0:ns), telab(ns), tilab(ns), xlogd(0:ns), sig39(ns), &
            xlogr(0:ns), a39(ns), acut, b, sige, sigo, qmax, chisqe
    common /int/ ni, imp, nimax, ke
    ! CALCULATION OF SIGMA F
    ! TO GENERALIZE TO HAVE POINTS WITH DIFFERENT % ERRORS
    ! READ SIGA FROM SOME FILE.

    sumat = 0
    do 14 n = 1, ni
    14    sumat = sumat + a39(n)

    f1(0) = 0.d0
    do 16 j = 1, ni
        sigsm(j) = sig39(j) / sumat
        siga(j) = sig39(j) / a39(j)
    16    continue
    an1 = pi**2
    sigat = 0.
    swt = 0.
    sigzit(0) = 0.
    do 10 i = 1, ni
        !         x=dlog10(sig39(i))+15.d0
        !        siga0=a0+a1*x+a2*x**2+a3*x**3
        !        siga0 = 10**(siga0-2.d0)
        !	   siga0 =0.
        sigat = sigat + sigsm(i)**2
        sigf(i) = sigat
    10    continue
    !       sigat = sigat + 0.000
    !  CALCULATION OF SIGMA DELTA XI
    do 30 i = 1, ni
        if (f(i).le.acut) then
            fp = f(i) + f(i - 1)
            as1 = 1.d0 / fp**2 - 2.d0 / fp
            as2 = (f(i)**2 - 2 * f(i) * (f(i)**2 - f(i - 1)**2)) / fp**2
            sigzit(i) = 4.d0 * (sigat + sigf(i - 1) * as1 + siga(i)**2 * as2)
        else
            dzit2 = (dlog((1 - f(i)) / (1 - f(i - 1))) / an1)**2
            !            as1= (sigsm(i)/(an1*(1-f(i-1))))**2/dzit2
            as1 = ((f(i) - f(i - 1)) / an1)**2 / (1 - f(i - 1))**2
            sigzit(i) = ((sigat - sigf(i)) / (1 - f(i))**2 + siga(i)**2) * as1
            sigzit(i) = sigzit(i) / dzit2
        endif
    30    continue
    !ALCULATION OF SIGMA LOG
    do 40 i = 1, ni
        sigt = (sigt0 / tilab(i))**2
        wt(i) = dsqrt(sigt + sigzit(i)) * ee
        swt = swt + wt(i)
        rate = dsqrt(sigzit(i) / sigt)
    40     continue
    100    format(1x, 6(f12.8))
    return
end

double precision function gammq(a, x)
    implicit double precision (a-h, o-z)
    if(x.lt.0..or.a.le.0.)stop 'ERROR(GAMMQ): (x.lt.0..or.a.le.0.)'
    if(x.lt.a + 1.)then
        call gser(gamser, a, x, gln)
        gammq = 1. - gamser
    else
        call gcf(gammcf, a, x, gln)
        gammq = gammcf
    endif
    return
end

subroutine gser(gamser, a, x, gln)
    implicit double precision (a-h, o-z)
    parameter (itmax = 100, eps = 3.e-7)
    gln = gammln(a)
    if(x.le.0.)then
        if(x.lt.0.)stop 'ERROR(GSER): (x.lt.0.)'
        gamser = 0.
        return
    endif
    ap = a
    sum = 1. / a
    del = sum
    do 11 n = 1, itmax
        ap = ap + 1.
        del = del * x / ap
        sum = sum + del
        if(abs(del).lt.abs(sum) * eps)go to 1
    11    continue
    stop 'ERROR(GSER): a too large, itmax too small'
    1     gamser = sum * dexp(-x + a * dlog(x) - gln)
    return
end

subroutine gcf(gammcf, a, x, gln)
    implicit double precision (a-h, o-z)
    parameter (itmax = 100, eps = 3.e-7)
    gln = gammln(a)
    gold = 0.
    a0 = 1.
    a1 = x
    b0 = 0.
    b1 = 1.
    fac = 1.
    do 11 n = 1, itmax
        an = float(n)
        ana = an - a
        a0 = (a1 + a0 * ana) * fac
        b0 = (b1 + b0 * ana) * fac
        anf = an * fac
        a1 = x * a0 + anf * a1
        b1 = x * b0 + anf * b1
        if(a1.ne.0.)then
            fac = 1. / a1
            g = b1 * fac
            if(abs((g - gold) / g).lt.eps)goto 1
            gold = g
        endif
    11    continue
    stop 'ERROR(GCF): a too large, itmax too small'
    1     gammcf = dexp(-x + a * dlog(x) - gln) * g
    return
end

double precision function gammln(xx)
    implicit double precision (a-h, o-z)
    real*8 cof(6), stp, half, one, fpf, x, tmp, ser, xx
    data cof, stp/76.18009173d0, -86.50532033d0, 24.01409822d0, &
            -1.231739516d0, .120858003d-2, -.536382d-5, 2.50662827465d0/
    data half, one, fpf/0.5d0, 1.0d0, 5.5d0/
    x = xx - one
    tmp = x + fpf
    tmp = (x + half) * dlog(tmp) - tmp
    ser = one
    do 11 j = 1, 6
        x = x + one
        ser = ser + cof(j) / x
    11    continue
    gammln = tmp + dlog(stp * ser)
    return
end

!*********************************************************************