C$Procedure GFUDS ( GF, user defined scalar )

      SUBROUTINE GFUDS ( UDFUNS, UDQDEC, RELATE, REFVAL,
     .                   ADJUST, STEP,   CNFINE,
     .                   MW,     NW,     WORK,   RESULT  )

C$ Abstract
C
C     Perform a GF search on a user defined scalar quantity.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     GF
C     SPK
C     TIME
C     WINDOWS
C
C$ Keywords
C
C     EVENT
C     EPHEMERIS
C     SEARCH
C     WINDOW
C
C$ Declarations

      IMPLICIT NONE

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

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      EXTERNAL              UDQDEC
      EXTERNAL              UDFUNS

      CHARACTER*(*)         RELATE
      DOUBLE PRECISION      REFVAL
      DOUBLE PRECISION      ADJUST
      DOUBLE PRECISION      STEP
      DOUBLE PRECISION      CNFINE ( LBCELL : * )
      INTEGER               MW
      INTEGER               NW
      DOUBLE PRECISION      WORK   ( LBCELL : MW, NW )
      DOUBLE PRECISION      RESULT ( LBCELL : * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     LBCELL     P   SPICE Cell lower bound.
C     CNVTOL     P   Convergence tolerance.
C     UDFUNS     I   Name of the routine that computes a scalar
C                    quantity corresponding to an ET.
C     UDQDEC     I   Name of the routine that computes whether the
C                    scalar quantity is decreasing.
C     RELATE     I   Operator that either looks for an extreme value
C                    (max, min, local, absolute) or compares the
C                    geometric quantity value and a number.
C     REFVAL     I   Value used as reference for scalar quantity
C                    condition.
C     ADJUST     I   Allowed variation for absolute extremal
C                    geometric conditions.
C     STEP       I   Step size used for locating extrema and roots.
C     CNFINE     I   SPICE window to which the search is confined.
C     MW         I   Size of workspace windows.
C     NW         I   Number of workspace windows.
C     WORK       I   Array containing workspace windows.
C     RESULT    I-O  SPICE window containing results.
C
C$ Detailed_Input
C
C     UDFUNS     the routine that returns the value of the scalar
C                quantity of interest at time ET. The calling sequence
C                for UDFUNS is:
C
C                   CALL UDFUNS ( ET, VALUE )
C
C                where:
C
C                   ET      a double precision value representing
C                           ephemeris time, expressed as seconds past
C                           J2000 TDB, at which to determine the scalar
C                           value.
C
C                   VALUE   is the value of the scalar quantity
C                           at ET.
C
C     UDQDEC     the name of the routine that determines if the scalar
C                quantity calculated by UDFUNS is decreasing.
C                The calling sequence of UDQDEC is:
C
C                   CALL UDQDEC ( UDFUNS, ET, ISDECR )
C
C                where:
C
C                   UDFUNS   the name of the scalar function as
C                            defined above.
C
C                   ET       a double precision value representing
C                            ephemeris time, expressed as seconds past
C                            J2000 TDB, at which to determine the time
C                            derivative of UDFUNS.
C
C                   ISDECR   a logical return indicating whether
C                            or not the scalar value returned by UDFUNS
C                            is decreasing. ISDECR returns true if the
C                            time derivative of UDFUNS at ET is
C                            negative.
C
C     RELATE     the scalar string comparison operator indicating
C                the numeric constraint of interest. Values are:
C
C                   '>'       value of scalar quantity greater than some
C                             reference (REFVAL).
C
C                   '='       value of scalar quantity equal to some
C                             reference (REFVAL).
C
C                   '<'       value of scalar quantity less than some
C                             reference (REFVAL).
C
C                   'ABSMAX'  The scalar quantity is at an absolute
C                             maximum.
C
C                   'ABSMIN'  The scalar quantity is at an absolute
C                              minimum.
C
C                   'LOCMAX'  The scalar quantity is at a local
C                             maximum.
C
C                   'LOCMIN'  The scalar quantity is at a local
C                             minimum.
C
C                The caller may indicate that the region of interest
C                is the set of time intervals where the quantity is
C                within a specified distance of an absolute extremum.
C                The argument ADJUST (described below) is used to
C                specified this distance.
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                RELATE is insensitive to case, leading and
C                trailing blanks.
C
C     REFVAL     is the reference value used to define an equality or
C                inequality to  satisfied by the scalar quantity.
C                The units of REFVAL are those of the scalar quantity.
C
C     ADJUST     the amount by which the quantity is allowed to vary
C                from an absolute extremum.
C
C                If the search is for an absolute minimum is performed,
C                the resulting window contains time intervals when the
C                geometric quantity value has values between
C                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                ADJUST is not used for searches for local extrema,
C                equality or inequality conditions and must have value
C                zero for such searches.
C
C     STEP       the double precision time step size to use in
C                the search.
C
C                STEP must be short enough to for a search using this
C                step size to locate the time intervals where the
C                scalar quantity function is monotone increasing or
C                decreasing. However, STEP must not be *too* short,
C                or the search will take an unreasonable amount of time.
C
C                The choice of STEP affects the completeness but not
C                the precision of solutions found by this routine; the
C                precision is controlled by the convergence tolerance.
C                See the discussion of the parameter CNVTOL for
C                details.
C
C                STEP has units of TDB seconds.
C
C     CNFINE     is a SPICE window that confines the time period over
C                which the specified search is conducted. CNFINE may
C                consist of a single interval or a collection of
C                intervals.
C
C                In some cases the confinement window can be used to
C                greatly reduce the time period that must be searched
C                for the desired solution. See the Particulars section
C                below for further discussion.
C
C                See the Examples section below for a code example
C                that shows how to create a confinement window.
C
C                CNFINE must be initialized by the caller via the
C                SPICELIB routine SSIZED.
C
C     MW         is a parameter specifying the length of the SPICE
C                windows in the workspace array WORK (see description
C                below) used by this routine.
C
C                MW should be set to a number at least twice as large
C                as the maximum number of intervals required by any
C                workspace window. In many cases, it's not necessary to
C                compute an accurate estimate of how many intervals are
C                needed; rather, the user can pick a size considerably
C                larger than what's really required.
C
C                However, since excessively large arrays can prevent
C                applications from compiling, linking, or running
C                properly, sometimes MW must be set according to
C                the actual workspace requirement. A rule of thumb
C                for the number of intervals NINTVLS needed is
C
C                   NINTVLS  =  2*N  +  ( M / STEP )
C
C                where
C
C                   N     is the number of intervals in the confinement
C                         window
C
C                   M     is the measure of the confinement window, in
C                         units of seconds
C
C                   STEP  is the search step size in seconds
C
C                MW should then be set to
C
C                   2 * NINTVLS
C
C     NW         is a parameter specifying the number of SPICE windows
C                in the workspace array WORK (see description below)
C                used by this routine.  (The reason this dimension is
C                an input argument is that this allows run-time
C                error checking to be performed.)
C
C                NW must be at least as large as the parameter NWUDS.
C
C     WORK       is an array used to store workspace windows. This
C                array should be declared by the caller as shown:
C
C                    DOUBLE PRECISION     WORK ( LBCELL : MW,  NW )
C
C                WORK need not be initialized by the caller.
C
C     RESULT     a double precision SPICE window which will contain the
C                search results. RESULT must be declared and initialized
C                with sufficient size to capture the full set of time
C                intervals within the search region on which the
C                specified constraint is satisfied.
C
C                RESULT must be initialized by the caller via the
C                SPICELIB routine SSIZED.
C
C                If RESULT is non-empty on input, its contents
C                will be discarded before GFUDS conducts its search.
C
C$ Detailed_Output
C
C     WORK       the input workspace array, modified by this
C                routine.
C
C     RESULT     is a SPICE window containing the time intervals within
C                the confinement window, during which the specified
C                condition on the scalar quantity is met.
C
C                If the search is for local extrema, or for absolute
C                extrema with ADJUST set to zero, then normally each
C                interval of RESULT will be a singleton: the left and
C                right endpoints of each interval will be identical.
C
C                If no times within the confinement window satisfy the
C                search, RESULT will be returned with a cardinality
C                of zero.
C
C$ Parameters
C
C     LBCELL   the integer value defining the lower bound for
C              SPICE Cell arrays (a SPICE window is a kind of cell).
C
C     CNVTOL   is the convergence tolerance used for finding
C              endpoints of the intervals comprising the result
C              window. CNVTOL is also used for finding intermediate
C              results; in particular, CNVTOL is used for finding the
C              windows on which the range rate is increasing
C              or decreasing. CNVTOL is used to determine when binary
C              searches for roots should terminate: when a root is
C              bracketed within an interval of length CNVTOL; the
C              root is considered to have been found.
C
C              The accuracy, as opposed to precision, of roots found
C              by this routine depends on the accuracy of the input
C              data. In most cases, the accuracy of solutions will be
C              inferior to their precision.
C
C     See INCLUDE file gf.inc for declarations and descriptions of
C     parameters used throughout the GF system.
C
C$ Exceptions
C
C     1)  In order for this routine to produce correct results,
C         the step size must be appropriate for the problem at hand.
C         Step sizes that are too large may cause this routine to miss
C         roots; step sizes that are too small may cause this routine
C         to run unacceptably slowly and in some cases, find spurious
C         roots.
C
C         This routine does not diagnose invalid step sizes, except
C         that if the step size is non-positive, the error
C         SPICE(INVALIDSTEP) is signaled.
C
C     2)  Due to numerical errors, in particular,
C
C            - truncation error in time values
C            - finite tolerance value
C            - errors in computed geometric quantities
C
C         it is *normal* for the condition of interest to not always be
C         satisfied near the endpoints of the intervals comprising the
C         RESULT window. One technique to handle such a situation,
C         slightly contract RESULT using the window routine WNCOND.
C
C     3)  If the workspace window size MW is less than 2 or not an even
C         value, the error SPICE(INVALIDDIMENSION) will signal. If the
C         size of the workspace is too small, an error is signaled by a
C         routine in the call tree of this routine.
C
C     4)  If the size of the SPICE window RESULT is less than 2 or
C         not an even value, the error SPICE(INVALIDDIMENSION) will
C         signal. If RESULT has insufficient capacity to contain the
C         number of intervals on which the specified condition
C         is met, the error will be diagnosed by a routine in the call
C         tree of this routine.
C
C     5)  If the window count NW is less than NWUDS, the error
C         SPICE(INVALIDDIMENSION) will be signaled.
C
C     6)  If an error (typically cell overflow) occurs during
C         window arithmetic, the error will be diagnosed by a routine
C         in the call tree of this routine.
C
C     7)  If the relational operator RELATE is not recognized, an
C         error is signaled by a routine in the call tree of this
C         routine.
C
C     8)  If ADJUST is negative, the error SPICE(VALUEOUTOFRANGE) will
C         signal from a routine in the call tree of this routine.
C
C         A non-zero value for ADJUST when RELATE has any value other
C         than "ABSMIN" or "ABSMAX" causes the error SPICE(INVALIDVALUE)
C         to signal from a routine in the call tree of this routine.
C
C     9)  If required ephemerides or other kernel data are not
C         available, an error is signaled by a routine in the call tree
C         of this routine.
C
C$ Files
C
C     Appropriate kernels must be loaded by the calling program before
C     this routine is called.
C
C     If the scalar function requires access to ephemeris data:
C
C        - SPK data: ephemeris data for any body over the
C          time period defined by the confinement window must be
C          loaded. If aberration corrections are used, the states of
C          target and observer relative to the solar system barycenter
C          must be calculable from the available ephemeris data.
C          Typically ephemeris data are made available by loading one
C          or more SPK files via FURNSH.
C
C        - If non-inertial reference frames are used, then PCK
C          files, frame kernels, C-kernels, and SCLK kernels may be
C          needed.
C
C     In all cases, kernel data are normally loaded once per program
C     run, NOT every time this routine is called.
C
C$ Particulars
C
C     This routine determines a set of one or more time intervals
C     within the confinement window when the scalar function
C     satisfies a caller-specified constraint. The resulting set of
C     intervals is returned as a SPICE window.
C
C     UDQDEC Default Template
C     =======================
C
C     The user must supply a routine to determine whether sign of the
C     time derivative of UDFUNS is positive or negative at ET. For
C     cases where UDFUNS is numerically well behaved, the user
C     may find it convenient to use a routine based on the below
C     template. UDDC determines the truth of the expression
C
C        d (UDFUNS)
C        --         < 0
C        dt
C
C     using the library routine UDDF to numerically calculate the
C     derivative of UDFUNS using a three-point estimation.
C     Please see the Examples section for an example of GFDECR use.
C
C           SUBROUTINE GFDECR ( UDFUNS, ET, ISDECR )
C           IMPLICIT NONE
C
C           EXTERNAL              UDFUNS
C           EXTERNAL              UDDF
C
C           DOUBLE PRECISION      ET
C           LOGICAL               ISDECR
C
C           DOUBLE PRECISION      DT
C
C           DT =  h, double precision interval size
C
C           CALL UDDC ( UDFUNS, ET, DT, ISDECR )
C
C           END
C
C     The Search Process
C     ==================
C
C     Regardless of the type of constraint selected by the caller, this
C     routine starts the search for solutions by determining the time
C     periods, within the confinement window, over which the specified
C     scalar function is monotone increasing and monotone
C     decreasing. Each of these time periods is represented by a SPICE
C     window. Having found these windows, all of the quantity
C     function's local extrema within the confinement window are known.
C     Absolute extrema then can be found very easily.
C
C     Within any interval of these "monotone" windows, there will be at
C     most one solution of any equality constraint. Since the boundary
C     of the solution set for any inequality constraint is contained in
C     the union of
C
C        - the set of points where an equality constraint is met
C        - the boundary points of the confinement window
C
C     the solutions of both equality and inequality constraints can be
C     found easily once the monotone windows have been found.
C
C
C     Step Size
C     =========
C
C     The monotone windows (described above) are found using a two-step
C     search process. Each interval of the confinement window is
C     searched as follows: first, the input step size is used to
C     determine the time separation at which the sign of the rate of
C     change of quantity function will be sampled. Starting at
C     the left endpoint of an interval, samples will be taken at each
C     step. If a change of sign is found, a root has been bracketed; at
C     that point, the time at which the time derivative of the quantity
C     function is zero can be found by a refinement process, for
C     example, using a binary search.
C
C     Note that the optimal choice of step size depends on the lengths
C     of the intervals over which the quantity function is monotone:
C     the step size should be shorter than the shortest of these
C     intervals (within the confinement window).
C
C     The optimal step size is *not* necessarily related to the lengths
C     of the intervals comprising the result window. For example, if
C     the shortest monotone interval has length 10 days, and if the
C     shortest result window interval has length 5 minutes, a step size
C     of 9.9 days is still adequate to find all of the intervals in the
C     result window. In situations like this, the technique of using
C     monotone windows yields a dramatic efficiency improvement over a
C     state-based search that simply tests at each step whether the
C     specified constraint is satisfied. The latter type of search can
C     miss solution intervals if the step size is longer than the
C     shortest solution interval.
C
C     Having some knowledge of the relative geometry of the targets and
C     observer can be a valuable aid in picking a reasonable step size.
C     In general, the user can compensate for lack of such knowledge by
C     picking a very short step size; the cost is increased computation
C     time.
C
C     Note that the step size is not related to the precision with which
C     the endpoints of the intervals of the result window are computed.
C     That precision level is controlled by the convergence tolerance.
C
C
C     Convergence Tolerance
C     =====================
C
C     Once a root has been bracketed, a refinement process is used to
C     narrow down the time interval within which the root must lie.
C     This refinement process terminates when the location of the root
C     has been determined to within an error margin called the
C     "convergence tolerance." The default convergence tolerance
C     used by this routine is set by the parameter CNVTOL (defined
C     in gf.inc).
C
C     The value of CNVTOL is set to a "tight" value so that the
C     tolerance doesn't become the limiting factor in the accuracy of
C     solutions found by this routine. In general the accuracy of input
C     data will be the limiting factor.
C
C     The user may change the convergence tolerance from the default
C     CNVTOL value by calling the routine GFSTOL, e.g.
C
C        CALL GFSTOL( tolerance value )
C
C     Call GFSTOL prior to calling this routine. All subsequent
C     searches will use the updated tolerance value.
C
C     Setting the tolerance tighter than CNVTOL is unlikely to be
C     useful, since the results are unlikely to be more accurate.
C     Making the tolerance looser will speed up searches somewhat,
C     since a few convergence steps will be omitted. However, in most
C     cases, the step size is likely to have a much greater effect
C     on processing time than would the convergence tolerance.
C
C
C     The Confinement Window
C     ======================
C
C     The simplest use of the confinement window is to specify a time
C     interval within which a solution is sought. However, the
C     confinement window can, in some cases, be used to make searches
C     more efficient. Sometimes it's possible to do an efficient search
C     to reduce the size of the time period over which a relatively
C     slow search of interest must be performed.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as
C     input, the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     Use the meta-kernel shown below to load the required SPICE
C     kernels.
C
C           KPL/MK
C
C           File name: standard.tm
C
C           This meta-kernel is intended to support operation of SPICE
C           example programs. The kernels shown here should not be
C           assumed to contain adequate or correct versions of data
C           required by SPICE-based user applications.
C
C           In order for an application to use this meta-kernel, the
C           kernels referenced here must be present in the user's
C           current working directory.
C
C
C           \begindata
C
C              KERNELS_TO_LOAD = ( 'de414.bsp',
C                                  'pck00008.tpc',
C                                  'naif0009.tls'  )
C
C           \begintext
C
C     Conduct a search on the range-rate of the vector from the Sun
C     to the Moon. Define a function to calculate the value.
C
C        Code:
C
C           PROGRAM GFUDS_T
C           IMPLICIT NONE
C
C     C
C     C     Include GF parameter declarations:
C     C
C           INCLUDE 'gf.inc'
C
C           EXTERNAL     GFQ
C           EXTERNAL     GFDECR
C
C     C
C     C     SPICELIB functions
C     C
C           DOUBLE PRECISION      SPD
C           DOUBLE PRECISION      DVNORM
C           INTEGER               WNCARD
C
C     C
C     C     Local parameters
C     C
C           INTEGER               LBCELL
C           PARAMETER           ( LBCELL = -5 )
C
C     C
C     C     Use the parameter MAXWIN for both the result window size
C     C     and the workspace size.
C     C
C           INTEGER               MAXWIN
C           PARAMETER           ( MAXWIN = 20000 )
C
C     C
C     C     Length of strings:
C     C
C           INTEGER               TIMLEN
C           PARAMETER           ( TIMLEN = 26 )
C
C           INTEGER               NLOOPS
C           PARAMETER           ( NLOOPS = 7 )
C
C     C
C     C     Local variables
C     C
C           CHARACTER*(TIMLEN)    TIMSTR
C           CHARACTER*(TIMLEN)    RELATE (NLOOPS)
C
C           DOUBLE PRECISION      ADJUST
C           DOUBLE PRECISION      CNFINE ( LBCELL : 2 )
C           DOUBLE PRECISION      DRDT
C           DOUBLE PRECISION      ET0
C           DOUBLE PRECISION      ET1
C           DOUBLE PRECISION      FINISH
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      POS    ( 6 )
C           DOUBLE PRECISION      REFVAL
C           DOUBLE PRECISION      RESULT ( LBCELL : MAXWIN )
C           DOUBLE PRECISION      START
C           DOUBLE PRECISION      STEP
C           DOUBLE PRECISION      WORK   ( LBCELL : MAXWIN, NWUDS )
C
C           INTEGER               I
C           INTEGER               J
C
C
C           DATA                  RELATE / '=',
C          .                               '<',
C          .                               '>',
C          .                               'LOCMIN',
C          .                               'ABSMIN',
C          .                               'LOCMAX',
C          .                               'ABSMAX'  /
C
C     C
C     C     Load kernels.
C     C
C           CALL FURNSH ( 'standard.tm' )
C
C     C
C     C     Initialize windows.
C     C
C           CALL SSIZED ( MAXWIN, RESULT )
C           CALL SSIZED ( 2,      CNFINE )
C
C           CALL SCARDD ( 0,      CNFINE )
C
C     C
C     C     Store the time bounds of our search interval in
C     C     the confinement window.
C     C
C           CALL STR2ET ( '2007 JAN 1', ET0 )
C           CALL STR2ET ( '2007 APR 1', ET1 )
C
C           CALL WNINSD ( ET0, ET1, CNFINE )
C
C     C
C     C     Search using a step size of 1 day (in units of seconds).
C     C     The reference value is .3365 km/s - a range rate value known
C     C     to exist during the confinement window. We're not using the
C     C     adjustment feature, so we set ADJUST to zero.
C     C
C           STEP   = SPD()
C           REFVAL = .3365D0
C           ADJUST = 0.D0
C
C           DO J=1, NLOOPS
C
C              WRITE(*,*) 'Relation condition: ', RELATE(J)
C
C     C
C     C        Perform the search. The SPICE window RESULT contains
C     C        the set of times when the condition is met.
C     C
C              CALL GFUDS ( GFQ,       GFDECR,
C          .                RELATE(J), REFVAL,  ADJUST, STEP, CNFINE,
C          .                MAXWIN,    NWUDS,   WORK,   RESULT )
C
C
C     C
C     C        Display the results.
C     C
C              IF ( WNCARD(RESULT) .EQ. 0 ) THEN
C
C                 WRITE (*, '(A)') 'Result window is empty.'
C
C              ELSE
C
C                 DO I = 1, WNCARD(RESULT)
C     C
C     C              Fetch the endpoints of the Ith interval
C     C              of the result window.
C     C
C                    CALL WNFETD ( RESULT, I, START, FINISH )
C
C                    CALL SPKEZR ( 'MOON',  START, 'J2000', 'NONE',
C          .                       'SUN', POS,   LT              )
C                    DRDT = DVNORM(POS)
C
C                    CALL TIMOUT ( START, 'YYYY-MON-DD HR:MN:SC.###',
C          .                       TIMSTR                            )
C
C                    WRITE (*, '(A,F16.9)' ) 'Start time, drdt = '//
C          .                                 TIMSTR, DRDT
C
C                    CALL SPKEZR ( 'MOON',  FINISH, 'J2000', 'NONE',
C          .                       'SUN', POS,     LT              )
C                    DRDT = DVNORM(POS)
C
C                    CALL TIMOUT ( FINISH, 'YYYY-MON-DD HR:MN:SC.###',
C          .                       TIMSTR                            )
C
C                    WRITE (*, '(A,F16.9)' ) 'Stop time,  drdt = '//
C          .                              TIMSTR, DRDT
C                 END DO
C
C              END IF
C
C              WRITE(*,*) ' '
C
C           END DO
C
C           END
C
C
C
C     C-Procedure GFQ
C
C           SUBROUTINE GFQ ( ET, VALUE )
C           IMPLICIT NONE
C
C     C- Abstract
C     C
C     C     User defined geometric quantity function. In this case,
C     C     the range from the sun to the Moon at TDB time ET.
C     C
C
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      VALUE
C
C     C
C     C     Local variables.
C     C
C           INTEGER               TARG
C           INTEGER               OBS
C
C           CHARACTER*(12)        REF
C           CHARACTER*(12)        ABCORR
C
C           DOUBLE PRECISION      STATE ( 6 )
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      DVNORM
C
C     C
C     C     Initialization. Retrieve the vector from the Sun to
C     C     the Moon in the J2000 frame, without aberration
C     C     correction.
C     C
C           TARG   = 301
C           REF    = 'J2000'
C           ABCORR = 'NONE'
C           OBS    = 10
C
C           CALL SPKEZ ( TARG, ET, REF, ABCORR, OBS, STATE, LT )
C
C     C
C     C     Calculate the scalar range rate corresponding the
C     C     STATE vector.
C     C
C           VALUE = DVNORM( STATE )
C
C           END
C
C
C
C
C     C-Procedure GFDECR
C
C           SUBROUTINE GFDECR ( UDFUNS, ET, ISDECR )
C           IMPLICIT NONE
C
C     C- Abstract
C     C
C     C     User defined function to detect if the function derivative
C     C     is negative (the function is decreasing) at TDB time ET.
C     C
C
C           EXTERNAL              UDFUNS
C           EXTERNAL              UDDF
C
C           DOUBLE PRECISION      ET
C           LOGICAL               ISDECR
C
C           DOUBLE PRECISION      DT
C
C           DT = 1.D0
C
C     C
C     C     Determine if GFQ is decreasing at ET.
C     C
C     C     UDDC - the default GF function to determine if
C     C                the derivative of the user defined
C     C                function is negative at ET.
C     C
C     C     UDFUNS - the user defined scalar quantity function.
C     C
C           CALL UDDC ( UDFUNS, ET, DT, ISDECR )
C
C           END
C
C     The program outputs:
C
C      Relation condition: =
C     Start time, drdt = 2007-JAN-02 00:35:19.574       0.336500000
C     Stop time,  drdt = 2007-JAN-02 00:35:19.574       0.336500000
C     Start time, drdt = 2007-JAN-19 22:04:54.899       0.336500000
C     Stop time,  drdt = 2007-JAN-19 22:04:54.899       0.336500000
C     Start time, drdt = 2007-FEB-01 23:30:13.428       0.336500000
C     Stop time,  drdt = 2007-FEB-01 23:30:13.428       0.336500000
C     Start time, drdt = 2007-FEB-17 11:10:46.540       0.336500000
C     Stop time,  drdt = 2007-FEB-17 11:10:46.540       0.336500000
C     Start time, drdt = 2007-MAR-04 15:50:19.929       0.336500000
C     Stop time,  drdt = 2007-MAR-04 15:50:19.929       0.336500000
C     Start time, drdt = 2007-MAR-18 09:59:05.959       0.336500000
C     Stop time,  drdt = 2007-MAR-18 09:59:05.959       0.336500000
C
C      Relation condition: <
C     Start time, drdt = 2007-JAN-02 00:35:19.574       0.336500000
C     Stop time,  drdt = 2007-JAN-19 22:04:54.899       0.336500000
C     Start time, drdt = 2007-FEB-01 23:30:13.428       0.336500000
C     Stop time,  drdt = 2007-FEB-17 11:10:46.540       0.336500000
C     Start time, drdt = 2007-MAR-04 15:50:19.929       0.336500000
C     Stop time,  drdt = 2007-MAR-18 09:59:05.959       0.336500000
C
C      Relation condition: >
C     Start time, drdt = 2007-JAN-01 00:00:00.000       0.515522367
C     Stop time,  drdt = 2007-JAN-02 00:35:19.574       0.336500000
C     Start time, drdt = 2007-JAN-19 22:04:54.899       0.336500000
C     Stop time,  drdt = 2007-FEB-01 23:30:13.428       0.336500000
C     Start time, drdt = 2007-FEB-17 11:10:46.540       0.336500000
C     Stop time,  drdt = 2007-MAR-04 15:50:19.929       0.336500000
C     Start time, drdt = 2007-MAR-18 09:59:05.959       0.336500000
C     Stop time,  drdt = 2007-APR-01 00:00:00.000       0.793546222
C
C      Relation condition: LOCMIN
C     Start time, drdt = 2007-JAN-11 07:03:58.988      -0.803382743
C     Stop time,  drdt = 2007-JAN-11 07:03:58.988      -0.803382743
C     Start time, drdt = 2007-FEB-10 06:26:15.439      -0.575837623
C     Stop time,  drdt = 2007-FEB-10 06:26:15.439      -0.575837623
C     Start time, drdt = 2007-MAR-12 03:28:36.404      -0.441800446
C     Stop time,  drdt = 2007-MAR-12 03:28:36.404      -0.441800446
C
C      Relation condition: ABSMIN
C     Start time, drdt = 2007-JAN-11 07:03:58.988      -0.803382743
C     Stop time,  drdt = 2007-JAN-11 07:03:58.988      -0.803382743
C
C      Relation condition: LOCMAX
C     Start time, drdt = 2007-JAN-26 02:27:33.766       1.154648992
C     Stop time,  drdt = 2007-JAN-26 02:27:33.766       1.154648992
C     Start time, drdt = 2007-FEB-24 09:35:07.816       1.347132236
C     Stop time,  drdt = 2007-FEB-24 09:35:07.816       1.347132236
C     Start time, drdt = 2007-MAR-25 17:26:56.150       1.428141707
C     Stop time,  drdt = 2007-MAR-25 17:26:56.150       1.428141707
C
C      Relation condition: ABSMAX
C     Start time, drdt = 2007-MAR-25 17:26:56.150       1.428141707
C     Stop time,  drdt = 2007-MAR-25 17:26:56.150       1.428141707
C
C$ Restrictions
C
C     1) Any kernel files required by this routine must be loaded
C        (normally via the SPICELIB routine FURNSH) before this routine
C        is called.
C
C$ Literature_References
C
C    None.
C
C$ Author_and_Institution
C
C    N.J. Bachman   (JPL)
C    E.D. Wright    (JPL)
C
C$ Version
C
C-   SPICELIB Version 1.1.0, 15-JUL-2014 (EDW)
C
C       Correction to description of UDQDEC to show UDFUNS as
C       an argument.
C
C       Edit to comments to correct search description.
C
C       Implemented use of ZZHOLDD to allow user to alter convergence
C       tolerance.
C
C       Removed the STEP > 0 error check. The GFSSTP call includes
C       the check.
C
C       Removed ZZGFREF call. That call now occurs in ZZGFRELX. Update
C       to ZZGFRELX argument list to reflect this change in
C       functionality.
C
C       Added RETURN() check.
C
C-   SPICELIB Version 1.0.0  16-FEB-2010 (EDW)
C
C-&

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

C
C     SPICELIB functions.
C

      LOGICAL               ODD
      LOGICAL               RETURN
      INTEGER               SIZED

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

      DOUBLE PRECISION      TOL
      LOGICAL               OK

      LOGICAL               GFBAIL
      EXTERNAL              GFBAIL

      LOGICAL               NOBAIL
      PARAMETER           ( NOBAIL = .FALSE. )

      LOGICAL               NORPT
      PARAMETER           ( NORPT  = .FALSE. )

C
C     Dummy variables.
C
      CHARACTER*(1)         RPTPRE ( 2 )
      CHARACTER*(1)         RPTSUF ( 2 )

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

      CALL CHKIN( 'GFUDS' )

C
C     Confirm minimum number of windows.
C
      IF ( NW .LT. NWUDS ) THEN

         CALL SETMSG ( 'Workspace window count was #; count must be '
     .   //            'at least #.'                                 )
         CALL ERRINT ( '#',  NW                                      )
         CALL ERRINT ( '#',  NWUDS                                   )
         CALL SIGERR ( 'SPICE(INVALIDDIMENSION)'                     )
         CALL CHKOUT ( 'GFUDS'                                       )
         RETURN

      END IF

C
C     Confirm minimum window sizes.
C
      IF ( (MW .LT. 2) .OR. ODD(MW) ) THEN

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

      END IF

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

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

      END IF

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

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

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

         TOL = CNVTOL

      END IF

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

C
C     Call ZZGFRELX to do the event detection work.
C
      CALL ZZGFRELX ( GFSTEP, GFREFN,    UDQDEC,  ZZGFUDLT,
     .                UDFUNS, RELATE,    REFVAL,
     .                TOL,    ADJUST,    CNFINE,  MW,
     .                NW,     WORK,      NORPT,   GFREPI,
     .                GFREPU, GFREPF,    RPTPRE,  RPTSUF,
     .                NOBAIL, GFBAIL,    RESULT   )

      CALL CHKOUT( 'GFUDS' )

      END


      subroutine calsoft_hyd_bfr_et

      use hru_module, only : cn2, hru, hru_init
      use soil_module
      use plant_module
      use hydrograph_module
      use ru_module
      use aquifer_module
      use channel_module
      use hru_lte_module
      use sd_channel_module
      use basin_module
      use maximum_data_module
      use calibration_data_module
      use conditional_module
      use reservoir_module
      use organic_mineral_mass_module
      use time_module

      implicit none

      integer :: iter_all      !none      |counter
      integer :: iterall       !none      |counter
      integer :: isim          !          |
      integer :: ireg          !none      |counter
      integer :: ilum          !none      |counter
      integer :: iihru         !none      |counter
      integer :: icn           !none      |counter
      integer :: ihru_s        !none      |counter
      integer :: iter_ind      !          |end of loop
      integer :: ietco         !none      |counter
      integer :: ik            !none      |counter
      integer :: nly           !          |end of loop
      integer :: iperco        !none      |counter
      real :: rmeas            !          |
      real :: denom            !          |
      real :: soft             !          |
      real :: diff             !          |
      real :: rto              !          |
      real :: chg_val          !          |
      real :: dep_below_soil   !          |
      real :: perc_ln_func

      ! calibrate esco and pet for water yield
        iter_ind = 1

        ! 1st esco adjustment
        isim = 0
        do ireg = 1, db_mx%lsu_reg
          do ilum = 1, region(ireg)%nlum
            soft = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa
            diff = 0.
            if (soft > 1.e-6) diff = abs((soft - lscal(ireg)%lum(ilum)%aa%wyr) / soft)
            if (diff > .01 .and. lscal(ireg)%lum(ilum)%ha > 1.e-6 .and. lscal(ireg)%lum(ilum)%prm_lim%etco < 1.e-6) then
            isim = 1

                lscal(ireg)%lum(ilum)%prm_prev = lscal(ireg)%lum(ilum)%prm
                lscal(ireg)%lum(ilum)%prev = lscal(ireg)%lum(ilum)%aa

                diff = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa - lscal(ireg)%lum(ilum)%aa%wyr
                chg_val = - diff / 250.     ! increment etco .4 for every 100 mm difference
                lscal(ireg)%lum(ilum)%prm_prev%etco = lscal(ireg)%lum(ilum)%prm%etco
                lscal(ireg)%lum(ilum)%prm%etco = lscal(ireg)%lum(ilum)%prm%etco + chg_val
                lscal(ireg)%lum(ilum)%prev%wyr = lscal(ireg)%lum(ilum)%aa%wyr

                if (lscal(ireg)%lum(ilum)%prm%etco >= ls_prms(2)%pos) then
                  chg_val = ls_prms(2)%pos - lscal(ireg)%lum(ilum)%prm_prev%etco
                  lscal(ireg)%lum(ilum)%prm%etco = ls_prms(2)%pos
                  lscal(ireg)%lum(ilum)%prm_lim%etco = 1.
                end if
                if (lscal(ireg)%lum(ilum)%prm%etco <= ls_prms(2)%neg) then
                  chg_val = lscal(ireg)%lum(ilum)%prm_prev%etco + ls_prms(2)%neg
                  lscal(ireg)%lum(ilum)%prm%etco = ls_prms(2)%neg
                  lscal(ireg)%lum(ilum)%prm_lim%etco = 1.
                end if

            do ihru_s = 1, region(ireg)%num_tot
              iihru = region(ireg)%num(ihru_s)
              if (lscal(ireg)%lum(ilum)%meas%name == hru(iihru)%lum_group_c .or. lscal(ireg)%lum(ilum)%meas%name == "basin") then
                !set parms for 1st et calibration
                hru(iihru)%hyd%esco = hru(iihru)%hyd%esco + chg_val
                hru(iihru)%hyd%esco = amin1 (hru(iihru)%hyd%esco, ls_prms(2)%up)
                hru(iihru)%hyd%esco = Max (hru(iihru)%hyd%esco, ls_prms(2)%lo)
                hru_init(iihru)%hyd%esco = hru(iihru)%hyd%esco
                !hru(iihru)%hyd%epco = hru(iihru)%hyd%epco + chg_val * .5
                !hru(iihru)%hyd%epco = amin1 (hru(iihru)%hyd%epco, ls_prms(2)%up)
                !hru(iihru)%hyd%epco = Max (hru(iihru)%hyd%epco, ls_prms(2)%lo)
                !hru_init(iihru)%hyd%epco = hru(iihru)%hyd%epco
              end if
            end do
            lscal(ireg)%lum(ilum)%nbyr = 0
            lscal(ireg)%lum(ilum)%precip_aa = 0.
            lscal(ireg)%lum(ilum)%aa = lscal_z
            !zero plant calibration data in case plants are calibrated
            !plcal(ireg)%lum(ilum)%nbyr = 0
            !plcal(ireg)%lum(ilum)%precip_aa = 0.
            !plcal(ireg)%lum(ilum)%ha = 0.
            !plcal(ireg)%lum(ilum)%aa = plcal_z

          end if
          end do
        end do

        !! re-initialize all objects
        call re_initialize

        ! 1st esco adjustment
        if (isim > 0) then
          cal_sim =  " first esco adj "
          call time_control
        end if

        ! adjust et using esco
        do ietco = 1, 2     !iter_ind
          isim = 0
          do ireg = 1, db_mx%lsu_reg
          do ilum = 1, region(ireg)%nlum
            !check all hru"s for proper lum
            soft = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa
            diff = 0.
            if (soft > 1.e-6) diff = abs((soft - lscal(ireg)%lum(ilum)%aa%wyr) / soft)
            if (diff > .01 .and. lscal(ireg)%lum(ilum)%ha > 1.e-6 .and. lscal(ireg)%lum(ilum)%prm_lim%etco < 0.99) then
            isim = 1

                rmeas = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa
                denom = lscal(ireg)%lum(ilum)%prev%wyr - lscal(ireg)%lum(ilum)%aa%wyr
                if (abs(denom) > 1.e-6) then
                  chg_val = - (lscal(ireg)%lum(ilum)%prm_prev%etco - lscal(ireg)%lum(ilum)%prm%etco)                  &
                    * (lscal(ireg)%lum(ilum)%aa%wyr - rmeas) / denom
                else
                  diff = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa - lscal(ireg)%lum(ilum)%aa%wyr
                  chg_val = - diff / 200.
                end if
                ! lower chg_val - changing both esco and epco causes esco to go too low
                !chg_val = chg_val * .5

                lscal(ireg)%lum(ilum)%prm_prev%etco = lscal(ireg)%lum(ilum)%prm%etco
                lscal(ireg)%lum(ilum)%prm%etco = lscal(ireg)%lum(ilum)%prm%etco + chg_val
                lscal(ireg)%lum(ilum)%prev%wyr = lscal(ireg)%lum(ilum)%aa%wyr

                if (lscal(ireg)%lum(ilum)%prm%etco >= ls_prms(2)%pos) then
                  chg_val = ls_prms(2)%pos - lscal(ireg)%lum(ilum)%prm_prev%etco
                  lscal(ireg)%lum(ilum)%prm%etco = ls_prms(2)%pos
                  lscal(ireg)%lum(ilum)%prm_lim%etco = 1.
                end if
                if (lscal(ireg)%lum(ilum)%prm%etco <= ls_prms(2)%neg) then
                  chg_val = ls_prms(2)%neg - lscal(ireg)%lum(ilum)%prm_prev%etco
                  lscal(ireg)%lum(ilum)%prm%etco = ls_prms(2)%neg
                  lscal(ireg)%lum(ilum)%prm_lim%etco = 1.
                end if

            do ihru_s = 1, region(ireg)%num_tot
                iihru = region(ireg)%num(ihru_s)
              if (lscal(ireg)%lum(ilum)%meas%name == hru(iihru)%lum_group_c .or. lscal(ireg)%lum(ilum)%meas%name == "basin") then
                !set parms for et calibration
                hru(iihru)%hyd%esco = hru(iihru)%hyd%esco + chg_val
                hru(iihru)%hyd%esco = amin1 (hru(iihru)%hyd%esco, ls_prms(2)%up)
                hru(iihru)%hyd%esco = Max (hru(iihru)%hyd%esco, ls_prms(2)%lo)
                hru_init(iihru)%hyd%esco = hru(iihru)%hyd%esco
                !hru(iihru)%hyd%epco = hru(iihru)%hyd%epco + chg_val * .5
                !hru(iihru)%hyd%epco = amin1 (hru(iihru)%hyd%epco, ls_prms(2)%up)
                !hru(iihru)%hyd%epco = Max (hru(iihru)%hyd%epco, ls_prms(2)%lo)
                !hru_init(iihru)%hyd%epco = hru(iihru)%hyd%epco
              end if
            end do
            lscal(ireg)%lum(ilum)%nbyr = 0
            lscal(ireg)%lum(ilum)%precip_aa = 0.
            lscal(ireg)%lum(ilum)%aa = lscal_z
            !plcal(ireg)%lum(ilum)%nbyr = 0
            !plcal(ireg)%lum(ilum)%precip_aa = 0.
            !plcal(ireg)%lum(ilum)%ha = 0.
            !plcal(ireg)%lum(ilum)%aa = plcal_z
          end if
          end do
          end do

          !! re-initialize all objects
          call re_initialize

          !! re-initialize all objects
          call re_initialize

          ! et adjustment
          if (isim > 0) then
            cal_sim =  " esco adj "
            call time_control
          end if

        end do      ! iesco

        ! first calibrate potential et
        do ietco = 1, 2     !iter_ind
        isim = 0
        do ireg = 1, db_mx%lsu_reg
          do ilum = 1, region(ireg)%nlum

            soft = lscal(ireg)%lum(ilum)%meas%wyr * lscal(ireg)%lum(ilum)%precip_aa
            diff = 0.
            if (soft > 1.e-6) diff = abs((soft - lscal(ireg)%lum(ilum)%aa%wyr) / soft)
            if (diff > .01 .and. lscal(ireg)%lum(ilum)%ha > 1.e-6) then
            isim = 1

                lscal(ireg)%lum(ilum)%prm_prev = lscal(ireg)%lum(ilum)%prm
                lscal(ireg)%lum(ilum)%prev = lscal(ireg)%lum(ilum)%aa

                if (soft < lscal(ireg)%lum(ilum)%aa%wyr) then
                  chg_val = 1. + abs((soft - lscal(ireg)%lum(ilum)%aa%wyr) / soft)
                else
                  chg_val = 1. - abs((lscal(ireg)%lum(ilum)%aa%wyr - soft) / lscal(ireg)%lum(ilum)%aa%wyr)
                end if
                lscal(ireg)%lum(ilum)%prm_prev%petco = lscal(ireg)%lum(ilum)%prm%petco
                if (ietco == 1) then
                  lscal(ireg)%lum(ilum)%prm%petco = chg_val
                else
                  lscal(ireg)%lum(ilum)%prm%petco = lscal(ireg)%lum(ilum)%prm%petco * chg_val
                end if
                lscal(ireg)%lum(ilum)%prm_prev%petco = lscal(ireg)%lum(ilum)%aa%wyr

                if (lscal(ireg)%lum(ilum)%prm%petco >= ls_prms(4)%pos) then
                  chg_val = ls_prms(4)%pos
                  lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%pos
                  lscal(ireg)%lum(ilum)%prm_lim%petco = 1.
                end if
                if (lscal(ireg)%lum(ilum)%prm%petco <= ls_prms(4)%neg) then
                  chg_val = ls_prms(4)%neg
                  lscal(ireg)%lum(ilum)%prm%petco = ls_prms(4)%neg
                  lscal(ireg)%lum(ilum)%prm_lim%petco = 1.
                end if

            !check all hru"s for proper lum
            do ihru_s = 1, region(ireg)%num_tot
              iihru = region(ireg)%num(ihru_s)
              if (lscal(ireg)%lum(ilum)%meas%name == hru(iihru)%lum_group_c .or. lscal(ireg)%lum(ilum)%meas%name == "basin") then
                !set parms for pet adjustment and run
                hru(iihru)%hyd%harg_pet = chg_val * hru(iihru)%hyd%harg_pet
                hru(iihru)%hyd%harg_pet = amin1 (hru(iihru)%hyd%harg_pet, ls_prms(4)%up)
                hru(iihru)%hyd%harg_pet = Max (hru(iihru)%hyd%harg_pet, ls_prms(4)%lo)
                hru_init(iihru)%hyd%harg_pet = hru(iihru)%hyd%harg_pet
              end if
            end do

            lscal(ireg)%lum(ilum)%nbyr = 0
            lscal(ireg)%lum(ilum)%precip_aa = 0.
            lscal(ireg)%lum(ilum)%aa = lscal_z
          end if
          end do
        end do

        !! re-initialize all objects
        call re_initialize

        ! 1st cover adjustment
        if (isim > 0) then
          cal_sim =  " first pet adj "
          call time_control
        end if

      end do    ! petco iterations

	  return
      end subroutine calsoft_hyd_bfr_et


INTEGER Function FindRotatedAtom(iz,tau,jatom,latom)
  !USE sym2,   ONLY: tau, iz
  USE structure, ONLY: pos, mult, lattic
  IMPLICIT NONE
  INTEGER, intent(in) :: jatom, latom
  INTEGER, intent(in) :: iz(3,3)
  REAL*8, intent(in)  :: tau(3)
  !
  REAL*8  :: Rn(3), diff(3), diff2(3)
  INTEGER :: index, m
  REAL*8, PARAMETER :: toler = 1.D-7
  REAL*8 :: toler2
  toler2=1.5d0*toler

  Rn = matmul( transpose(iz(:,:)),pos(:,latom))
  Rn(:) = Rn(:) + tau(:)

  Rn(1) = MOD(Rn(1) + 1.d0, 1.d0)
  Rn(2) = MOD(Rn(2) + 1.d0, 1.d0)
  Rn(3) = MOD(Rn(3) + 1.d0, 1.d0)

  index = sum(mult(1:jatom-1))
  DO m=1,mult(jatom)
     index = index + 1
     diff(:) = MOD( abs( Rn(:) - pos(:,index))+toler, 1.d0) - toler
     !print *, 'm=', m, 'index=', index, 'diff=', diff
     if ( maxval(abs(diff)).lt.toler2 ) then
        FindRotatedAtom = index
        return
     endif
     !....check positions for centered lattices
     if(lattic(1:1).eq.'B') then
        diff(:) = mod(diff(:)+0.5d0+toler, 1.d0) - toler
        if ( maxval(abs(diff)).lt.toler2 ) then
           FindRotatedAtom = index
           return
        endif
     endif
     if(lattic(1:1).eq.'F'.or.lattic(1:3).eq.'CXY') then
        diff2(:) = diff(:)
        diff2(1) = mod(diff(1)+0.5d0+toler,1.d0)-toler
        diff2(2) = mod(diff(2)+0.5d0+toler,1.d0)-toler
        !print *, 'm=', m, 'index=', index, 'diff2=', diff2
        if ( maxval(abs(diff2)).lt.toler2 ) then
           FindRotatedAtom = index
           return
        endif
     endif
     if(lattic(1:1).eq.'F'.or.lattic(1:3).eq.'CXZ') then
        diff2(:) = diff(:)
        diff2(1) = mod( diff(1)+0.5d0+toler,1.d0)-toler
        diff2(3) = mod( diff(3)+0.5d0+toler,1.d0)-toler
        !print *, 'm=', m, 'index=', index, 'diff3=', diff2
        if (maxval(abs(diff2)).lt.toler2 ) then
           FindRotatedAtom = index
           return
        endif
     endif
     if(lattic(1:1).eq.'F'.or.lattic(1:3).eq.'CYZ') then
        diff2(:) = diff(:)
        diff2(2) = mod(diff(2)+0.5d0+toler,1.d0)-toler
        diff2(3) = mod(diff(3)+0.5d0+toler,1.d0)-toler
        !print *, 'm=', m, 'index=', index, 'diff4=', diff2
        if ( maxval(abs(diff2)).lt.toler2 ) then
           FindRotatedAtom = index
           return
        endif
     end if
  ENDDO
  WRITE(6,*) 'ERROR : Could not find equivalent atom in SymmetrizeDM. jatom=', jatom, 'latom=', latom, ' Boiling out'
  FindRotatedAtom = latom
end Function FindRotatedAtom

INTEGER Function FindRotatedCase(latom_rotated)
  use case, ONLY : natom, iatom
  IMPLICIT NONE
  INTEGER, intent(in) :: latom_rotated
  !
  INTEGER :: icase_rotated
  do icase_rotated=1,natom
     if ( iatom(icase_rotated).eq.latom_rotated ) then
        FindRotatedCase = icase_rotated
        return
     endif
  enddo
  WRITE(6,*) 'ERROR : Could not find equivalent icase in SymmetrizeDM. latom_rotated=', latom_rotated
  FindRotatedCase = 1
end Function FindRotatedCase

SUBROUTINE CmpSymmetryTransformation(ig, RT, cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2, Qprint)
  USE structure, ONLY: BR1, rotij, tau, iz
  USE case, ONLY: natom, nl, ll, cix, iatom, isort, maxdim, ncix, crotloc
  use com, ONLY: iso
  USE defs,  ONLY: IMAG
  USE param, ONLY: lmax2
  IMPLICIT NONE
  INTEGER, intent(in)      :: ig ! The index of the group operation
  COMPLEX*16, intent(out)  :: RT(maxdim,maxdim,ncix)  ! Symmetrization matrix for this group operation
  ! other needed inputs
  COMPLEX*16, intent(in)   :: cfX(maxdim2,maxdim2,norbitals,norbitals)
  INTEGER, intent(in)      :: cix_orb(norbitals), cixdim(ncix), iSx(maxdim2, norbitals), iorbital(natom,lmax2+1), nindo(norbitals)
  INTEGER, intent(in)      :: norbitals, maxdim2
  LOGICAL, intent(in)      :: Qprint
  ! external
  REAL*8 :: detx
  INTEGER :: FindRotatedAtom
  INTEGER :: FindRotatedCase
  !
  REAL*8     :: BR1inv(3,3), Id(3,3), TR(3,3), Det
  REAL*8     :: local_axis_latom(3,3), local_axis_rotated(3,3), local_axis_rotated_inv(3,3), Tac(3,3)
  INTEGER    :: icase, lcase, icix, nind, iorb, ni, iorb_rotated, iorb1, iorb2, i1, i2, jatom, latom, nind1, nind2, ind1, ind2
  INTEGER    :: l, cdim, i, j, latom_rotated, icase_rotated
  COMPLEX*16 :: Ds(2,2), tmp(maxdim2,maxdim2)
  COMPLEX*16, allocatable :: Dr(:,:), Drs(:,:)
  COMPLEX*16 :: Drx(maxdim2,maxdim2)
  !
  call inv_3x3(BR1,BR1inv)
  Id(:,:)=0.d0
  Id(1,1)=1.d0
  Id(2,2)=1.d0
  Id(3,3)=1.d0

  ! TR <=  BR1 * iz * BR1inv, is the rotation due to the group operation written in global coordinate system
  TR(:,:) = iz(:,:,ig)
  TR = matmul(BR1, matmul(TR, BR1inv) )

  if (Qprint) then
     WRITE(6,*) 'ig=', ig
     WRITE(6,*) 'iz='
     DO i=1,3
        WRITE(6,'(3I3,1x)') iz(i,:,ig)
     enddo
  endif

  RT(:,:,:) = 0.d0
  DO icase=1,natom
     latom = iatom(icase)   ! The succesive number of atom (all atoms counted)
     jatom = isort(latom)   ! The sort of the atom  ( == w_jatom(iucase) )

     latom_rotated = FindRotatedAtom(iz(:,:,ig),tau(:,ig),jatom,latom)
     icase_rotated = FindRotatedCase(latom_rotated)
     !print *, 'icase=', icase, 'icase_rotated=', icase_rotated

     do lcase=1,nl(icase)

        local_axis_latom   = matmul(crotloc(:,:,lcase,icase),         matmul(BR1, matmul(rotij(:,:,latom),         BR1inv)))
        local_axis_rotated = matmul(crotloc(:,:,lcase,icase_rotated), matmul(BR1, matmul(rotij(:,:,latom_rotated), BR1inv)))
        call inv_3x3(local_axis_rotated, local_axis_rotated_inv)

        Tac = matmul(local_axis_latom, matmul(TR, local_axis_rotated_inv))
        Det = detx(Tac)
        if (Det < 0.d0) then
           Tac = -Tac
        endif

        icix = cix(icase,lcase)
        if ( icix.EQ.0 ) CYCLE

        l = ll(icase,lcase)
        nind = (2*l+1)*iso
        iorb = iorbital(icase,lcase)
        iorb_rotated = iorbital(icase_rotated,lcase)

        allocate( Dr(nind,nind) )
        Dr = 0.d0
        if (sum(abs(Tac-Id)).LT.1e-10) then
           do i=1,nind   ! Identity requires no rotation
              Dr(i,i) = 1.d0
           enddo
        else
           ni = 2*l+1
           call GetWignerOrbitalMatrix(Dr(:ni,:ni), l, Tac)
           if (iso.eq.2) then ! Spin orbit requires simultaneous spin-rotations
              allocate( Drs(ni,ni) )
              Drs(:,:) = Dr(:ni,:ni)
              call GetWignerSpinMatrix(Ds, 1.d0/2.d0, Tac)
              Dr(:ni,    :ni) = Ds(1,1) * Drs(:,:)
              Dr(:ni,  ni+1:) = Ds(1,2) * Drs(:,:)
              Dr(ni+1:,  :ni) = Ds(2,1) * Drs(:,:)
              Dr(ni+1:,ni+1:) = Ds(2,2) * Drs(:,:)
              deallocate( Drs )
           endif
        endif

        if (Det.lt.0 .and. mod(l,2).eq.1) then  ! We have inversion, hence Y_{lm} -> (-1)^l Y_{lm}
           Dr(:,:) = Dr(:,:) * (-1)**l
        endif

        do iorb1=1,norbitals
           if (cix_orb(iorb) .NE. cix_orb(iorb1) ) CYCLE
           nind1 = nindo(iorb1)
           tmp(:nind1,:nind) = matmul( conjg(cfX(:nind1,:nind,iorb1,iorb)), Dr(:nind,:nind) )
           do iorb2=1,norbitals
              if (cix_orb(iorb_rotated) .NE. cix_orb(iorb2) ) CYCLE
              nind2 = nindo(iorb2)
              Drx(:nind1,:nind2) = matmul(tmp(:nind1,:nind), transpose(cfX(:nind2,:nind,iorb2,iorb_rotated)))
              do ind1=1,nind1
                 do ind2=1,nind2
                    i1 = iSx(ind1,iorb1)
                    i2 = iSx(ind2,iorb2)
                    RT(i1,i2,icix) = RT(i1,i2,icix) + Drx(ind1,ind2)
                 enddo
              enddo
           enddo
        enddo
        deallocate( Dr )
     enddo
  ENDDO

  if (Qprint) then
     do icix=1,ncix
        cdim = cixdim(icix)
        WRITE(6,*) 'icix=', icix
        do i=1,cdim
           do j=1,cdim
              WRITE(6,'(2F14.7,2x)',advance='no') RT(i,j,icix)
           enddo
           WRITE(6,*)
        enddo
     end do
  endif
END SUBROUTINE CmpSymmetryTransformation

SUBROUTINE SymmetrizeLocalQuantities(Gmloc, Eimpm, Olapm, s_oo, sigma, cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, noccur, maxdim2, nomega)
  USE structure,  ONLY: iord
  USE case, ONLY: maxdim, ncix, natom, maxsize, csize, Sigind
  USE defs,  ONLY: IMAG
  USE param, ONLY: lmax2
  IMPLICIT NONE
  COMPLEX*16, intent(inout):: Gmloc(maxdim,maxdim,ncix,nomega), Eimpm(maxdim,maxdim,ncix), Olapm(maxdim,maxdim,ncix)
  COMPLEX*16, intent(inout):: s_oo(maxsize,ncix), sigma(maxsize,ncix,nomega)
  INTEGER, intent(in)      :: cix_orb(norbitals), cixdim(ncix), iSx(maxdim2, norbitals), iorbital(natom,lmax2+1), nindo(norbitals), noccur(maxsize,ncix)
  INTEGER, intent(in)      :: norbitals, maxdim2, nomega
  COMPLEX*16, intent(in)   :: cfX(maxdim2,maxdim2,norbitals,norbitals)
  ! locals
  INTEGER    :: icix, ig, ip, iq, iom, it, i, j
  INTEGER    :: cdim
  COMPLEX*16 :: gc(maxdim,maxdim)
  !
  INTEGER    :: ncix_unique
  INTEGER    :: size_cix_unique(ncix)
  INTEGER    :: cix_unique(ncix,ncix)
  COMPLEX*16, allocatable :: tmp(:,:)
  !
  COMPLEX*16, allocatable :: RT(:,:,:,:), sig(:,:)

  allocate( RT(maxdim,maxdim,ncix,iord) )
  allocate( sig(maxdim,maxdim) )

  do ig=1,iord
     Call CmpSymmetryTransformation(ig, RT(:,:,:,ig), cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2, .False.)
  enddo

  do icix=1,ncix
     cdim = cixdim(icix)
     do iom=1,nomega
        ! Symmetrize the local Green's function
        gc(:,:)=0.d0
        do ig=1,iord
           gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(Gmloc(:cdim,:cdim,icix,iom), RT(:cdim,:cdim,icix,ig)))/iord
        end do
        Gmloc(:cdim,:cdim,icix,iom) = gc(:cdim,:cdim)

        ! Symmetrize the self-energy
        sig=0.d0
        DO ip=1,cdim
           do iq=1,cdim
              it = abs(Sigind(ip,iq,icix))
              if (it.ne.0) then
                 sig(ip,iq) = sigma(it,icix,iom)
              endif
           enddo
        ENDDO
        gc(:,:)=0.d0
        do ig=1,iord
           gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(sig(:cdim,:cdim), RT(:cdim,:cdim,icix,ig)))/iord
        end do
        sigma(:,icix,iom)=0.d0
        DO ip=1,cdim
           do iq=1,cdim
              it = abs(Sigind(ip,iq,icix))
              if (it.ne.0) then
                 sigma(it,icix,iom) = sigma(it,icix,iom) + gc(ip,iq)
              endif
           enddo
        ENDDO
        DO it=1,csize(icix)
           sigma(it, icix, iom) = sigma(it,icix,iom)/noccur(it,icix)
        ENDDO

     enddo

     ! Symmetrize the impurity levels
     gc(:,:)=0.d0
     do ig=1,iord
        gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(Eimpm(:cdim,:cdim,icix), RT(:cdim,:cdim,icix,ig)))/iord
     end do
     Eimpm(:cdim,:cdim,icix) = gc(:cdim,:cdim)
     ! Symmetrize the overlap
     gc(:,:)=0.d0
     do ig=1,iord
        gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(Olapm(:cdim,:cdim,icix), RT(:cdim,:cdim,icix,ig)))/iord
     end do
     Olapm(:cdim,:cdim,icix) = gc(:cdim,:cdim)

     ! Symmetrize the sigma infinity s_oo
     sig=0.d0
     DO ip=1,cdim
        do iq=1,cdim
           it = abs(Sigind(ip,iq,icix))
           if (it.ne.0) then
              sig(ip,iq) = s_oo(it,icix)
           endif
        enddo
     ENDDO
     gc(:,:)=0.d0
     do ig=1,iord
        gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(sig(:cdim,:cdim), RT(:cdim,:cdim,icix,ig)))/iord
     end do
     s_oo(:,icix)=0.d0
     DO ip=1,cdim
        do iq=1,cdim
           it = abs(Sigind(ip,iq,icix))
           if (it.ne.0) then
              s_oo(it,icix) = s_oo(it,icix) + gc(ip,iq)
           endif
        enddo
     ENDDO
     DO it=1,csize(icix)
        s_oo(it, icix) = s_oo(it,icix)/noccur(it,icix)
     ENDDO

  enddo

  deallocate( RT )

  ! Now symmetrize over equivalent cix
  call FindUniqueCix(ncix_unique, size_cix_unique, cix_unique)
  do i=1,ncix_unique
     if (size_cix_unique(i).eq.1) cycle ! no symmetrization necessary
     icix = cix_unique(i,1)
     cdim = cixdim(icix)
     allocate( tmp(cdim,cdim) )

     !Gmloc(:cdim,:cdim,icix,iom)
     do iom=1,nomega
        tmp=0.d0
        do j=1,size_cix_unique(i)
           icix = cix_unique(i,j)
           tmp(:,:) = tmp(:,:) + Gmloc(:cdim,:cdim,icix,iom)
        enddo
        tmp(:,:) = tmp(:,:)/size_cix_unique(i)
        do j=1,size_cix_unique(i)
           icix = cix_unique(i,j)
           Gmloc(:cdim,:cdim,icix,iom) = tmp(:,:)
        enddo
     enddo
     !Eimpm(:cdim,:cdim,icix)
     tmp=0.d0
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        tmp(:,:) = tmp(:,:) + Eimpm(:cdim,:cdim,icix)
     enddo
     tmp(:,:) = tmp(:,:)/size_cix_unique(i)
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        Eimpm(:cdim,:cdim,icix) = tmp(:,:)
     enddo
     !Olapm(:cdim,:cdim,icix)
     tmp=0.d0
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        tmp(:,:) = tmp(:,:) + Olapm(:cdim,:cdim,icix)
     enddo
     tmp(:,:) = tmp(:,:)/size_cix_unique(i)
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        Olapm(:cdim,:cdim,icix) = tmp(:,:)
     enddo

     deallocate( tmp )
  enddo

END SUBROUTINE SymmetrizeLocalQuantities

SUBROUTINE SymmetrizeLocalQuantities2(g_inf, g_ferm, cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2, nomega)
  USE structure,  ONLY: iord
  USE case, ONLY: maxdim, ncix, natom
  USE defs,  ONLY: IMAG
  USE param, ONLY: lmax2
  IMPLICIT NONE
  COMPLEX*16, intent(inout):: g_inf(maxdim,maxdim,ncix,nomega), g_ferm(maxdim,maxdim,ncix)
  INTEGER, intent(in)      :: cix_orb(norbitals), cixdim(ncix), iSx(maxdim2, norbitals), iorbital(natom,lmax2+1), nindo(norbitals)
  INTEGER, intent(in)      :: norbitals, maxdim2, nomega
  COMPLEX*16, intent(in)   :: cfX(maxdim2,maxdim2,norbitals,norbitals)
  ! locals
  INTEGER    :: icix, ig, iom, i, j
  INTEGER    :: cdim
  INTEGER    :: ncix_unique
  INTEGER    :: size_cix_unique(ncix)
  INTEGER    :: cix_unique(ncix,ncix)
  COMPLEX*16 :: gc(maxdim,maxdim)
  COMPLEX*16, allocatable :: RT(:,:,:,:), tmp(:,:)

  allocate( RT(maxdim,maxdim,ncix,iord) )

  do ig=1,iord
     Call CmpSymmetryTransformation(ig, RT(:,:,:,ig), cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2, .False.)
  enddo

  do icix=1,ncix
     cdim = cixdim(icix)
     do iom=1,nomega
        ! Symmetrize the local Green's function
        gc(:,:)=0.d0
        do ig=1,iord
           gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(g_inf(:cdim,:cdim,icix,iom), RT(:cdim,:cdim,icix,ig)))/iord
        end do
        g_inf(:cdim,:cdim,icix,iom) = gc(:cdim,:cdim)
     enddo
     gc(:,:)=0.d0
     do ig=1,iord
        gc(:cdim,:cdim) = gc(:cdim,:cdim) + matmul(conjg(transpose(RT(:cdim,:cdim,icix,ig))), matmul(g_ferm(:cdim,:cdim,icix), RT(:cdim,:cdim,icix,ig)))/iord
     end do
     g_ferm(:cdim,:cdim,icix) = gc(:cdim,:cdim)
  enddo

  deallocate( RT )

  ! Now symmetrize over equivalent cix
  call FindUniqueCix(ncix_unique, size_cix_unique, cix_unique)
  do i=1,ncix_unique
     if (size_cix_unique(i).eq.1) cycle ! no symmetrization necessary
     icix = cix_unique(i,1)
     cdim = cixdim(icix)
     allocate( tmp(cdim,cdim) )

     !g_inf(:cdim,:cdim,icix,iom)
     do iom=1,nomega
        tmp=0.d0
        do j=1,size_cix_unique(i)
           icix = cix_unique(i,j)
           tmp(:,:) = tmp(:,:) + g_inf(:cdim,:cdim,icix,iom)
        enddo
        tmp(:,:) = tmp(:,:)/size_cix_unique(i)
        do j=1,size_cix_unique(i)
           icix = cix_unique(i,j)
           g_inf(:cdim,:cdim,icix,iom) = tmp(:,:)
        enddo
     enddo
     !g_ferm(:cdim,:cdim,icix)
     tmp=0.d0
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        tmp(:,:) = tmp(:,:) + g_ferm(:cdim,:cdim,icix)
     enddo
     tmp(:,:) = tmp(:,:)/size_cix_unique(i)
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        g_ferm(:cdim,:cdim,icix) = tmp(:,:)
     enddo

     deallocate( tmp )
  enddo

END SUBROUTINE SymmetrizeLocalQuantities2

SUBROUTINE SymmetrizeOverlap(Olapm, cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2)
  USE structure,  ONLY: iord
  USE case, ONLY: maxdim, ncix, natom
  USE defs,  ONLY: IMAG
  USE param, ONLY: lmax2
  IMPLICIT NONE
  COMPLEX*16, intent(inout):: Olapm(maxdim,maxdim,ncix)
  INTEGER, intent(in)      :: cix_orb(norbitals), cixdim(ncix), iSx(maxdim2, norbitals), iorbital(natom,lmax2+1), nindo(norbitals)
  INTEGER, intent(in)      :: norbitals, maxdim2
  COMPLEX*16, intent(in)   :: cfX(maxdim2,maxdim2,norbitals,norbitals)
  ! locals
  INTEGER    :: icix, ig, i, j
  INTEGER    :: cdim
  INTEGER    :: ncix_unique
  INTEGER    :: size_cix_unique(ncix)
  INTEGER    :: cix_unique(ncix,ncix)
  !
  COMPLEX*16, allocatable :: tmp(:,:)
  COMPLEX*16, allocatable :: Olaps(:,:,:), RT(:,:,:)

  allocate( Olaps(maxdim,maxdim,ncix), RT(maxdim,maxdim,ncix) )

  Olaps(:,:,:)=0.d0
  do ig=1,iord
     Call CmpSymmetryTransformation(ig, RT(:,:,:), cfX, cix_orb, cixdim, iSx, iorbital, nindo, norbitals, maxdim2, .False.)
     do icix=1,ncix
        cdim = cixdim(icix)
        Olaps(:cdim,:cdim,icix) = Olaps(:cdim,:cdim,icix) + matmul(conjg(transpose(RT(:cdim,:cdim,icix))), matmul(Olapm(:cdim,:cdim,icix), RT(:cdim,:cdim,icix)))/iord
     enddo
  enddo

  ! Now symmetrize over equivalent cix
  call FindUniqueCix(ncix_unique, size_cix_unique, cix_unique)
  do i=1,ncix_unique
     if (size_cix_unique(i).eq.1) cycle ! no symmetrization necessary
     icix = cix_unique(i,1)
     cdim = cixdim(icix)
     allocate( tmp(cdim,cdim) )
     tmp=0.d0
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        tmp(:,:) = tmp(:,:) + Olaps(:cdim,:cdim,icix)
     enddo
     tmp(:,:) = tmp(:,:)/size_cix_unique(i)
     do j=1,size_cix_unique(i)
        icix = cix_unique(i,j)
        Olaps(:cdim,:cdim,icix) = tmp(:,:)
     enddo
     deallocate( tmp )
  enddo

  Olapm(:,:,:) = Olaps(:,:,:)
  deallocate( RT, Olaps )
END SUBROUTINE SymmetrizeOverlap

SUBROUTINE FindUniqueCix(ncix_unique, size_cix_unique, cix_unique)
  use case, ONLY: natom, ncix, iatom, isort, cix
  IMPLICIT NONE
  INTEGER, intent(out) :: ncix_unique
  INTEGER, intent(out) :: size_cix_unique(ncix)
  INTEGER, intent(out) :: cix_unique(ncix,ncix)
  !
  INTEGER :: cix_2_jatom(ncix)
  INTEGER :: icix, jatom_unique
  INTEGER :: icase, jatom, latom

  do icix=1,ncix
     DO icase=1,natom
        latom = iatom(icase)   ! The succesive number of atom (all atoms counted)
        jatom = isort(latom)   ! The sort of the atom  ( == w_jatom(iucase) )
        if (icix .eq. cix(icase,1)) then
           cix_2_jatom(icix) = jatom
           exit
        endif
     ENDDO
  enddo

  ncix_unique=1
  size_cix_unique(:)=0
  cix_unique(:,:)=0
  icix=1
  jatom_unique = cix_2_jatom(icix)
  do icix=1,ncix
     if ( cix_2_jatom(icix) .eq. jatom_unique ) then
        size_cix_unique(ncix_unique) = size_cix_unique(ncix_unique) + 1
        cix_unique( ncix_unique, size_cix_unique(ncix_unique) ) = icix
        cycle
     endif
     jatom_unique = cix_2_jatom(icix)
     ncix_unique = ncix_unique + 1
     size_cix_unique(ncix_unique) = size_cix_unique(ncix_unique) + 1
     cix_unique( ncix_unique, size_cix_unique(ncix_unique) ) = icix
  enddo

  !print *, 'icix=', icix-1, 'ncix_unique=', ncix_unique
  !print *, 'size_cix_unique: '
  !do i=1,ncix_unique
  !   print *, size_cix_unique(i)
  !enddo
  !print *, 'cix_unique: '
  !do i=1,ncix_unique
  !   do j=1,size_cix_unique(i)
  !      print *, i, j, cix_unique(i,j)
  !   enddo
  !enddo

END SUBROUTINE FindUniqueCix


program opconsAt
  use atoms_inp
  use potential_inp
  use geometry_inp
  use constants
  use AtomicPotIO
  use opcons_inp
  use par
  use errorfile
  implicit none
  integer iph, NComps ! , nnn, iph2, iX, iY, iZ2, iAt, iAt2
  character(2), allocatable :: Components(:)
  ! character(12), allocatable :: EpsFiles(:)
  character(12), allocatable :: thisfile
  character(2),external :: GetElement
  real(8),allocatable :: rnrm(:)
  real(8) VTot ! , rNN, r, rCnt(3), point(3), x2, y2, z2, dX
  ! REAL(8),PARAMETER :: RTol  = (3.d0)**2
  ! INTEGER,PARAMETER :: NGrid = 200

  character(12) EpsFile
  integer i1, i2, NDataTot, iUnit, NPoles
  integer, parameter :: epsmax = 700
  real(8) thiseps(epsmax,3,0:nphx)
  real(8) energy(epsmax), loss(epsmax)
  real(8) g(10000), gamma, omi(10000), Delta(10000), eps0, sumrl, xNElec, csumrl
  character ch

  logical excinp
  logical write_loss, write_opcons, write_exc, verbose
  write_loss   = .true.
  write_opcons = .true.
  write_exc    = .true.
  verbose      = .true.
  NPoles       = 100
  eps0         = -1.d0

  !KJ 1-2012:
  call par_begin
  if (worker) go to 400
  call OpenErrorfileAtLaunch('opconsat')

  !CALL opcons_read
  !IF(.NOT.run_opcons) STOP
  !if (.not. run_opcons) goto 400
  call opcons_init

  call atoms_read
  call potential_read

  allocate(Components(0:nph), rnrm(0:nph), thisfile)
  ! allocate(EpsFiles(0:nph))

  call ReadAtomicPots(nph, rnrm)
  if (verbose) print*, 'nph, rnrm', nph, rnrm

  ! Find the number density of each component.
  VTot = 0.d0
  do iph = 0, nph
     VTot = VTot + xnatph(iph)*4.d0/3.d0*pi*(rnrm(iph)*bohr)**3
  end do

  do iph = 0, nph
     if(NumDens(iph).lt.0.d0) NumDens(iph) = xnatph(iph)/VTot
     ! test with numDens = 1. Should give same loss as input file for a single file.
     if(.false.) then
        if(iph.ne.0) then
           NumDens(iph) = 1.d0
        else
           NumDens(iph) = 0.d0
        end if
     end if
     Components(iph) = GetElement(iz(iph))
  end do

  ! Get opcons{Element}.dat from database.
  do iph = 0, nph
     do i1 = 1,epsmax
        do i2 = 1,3
           thiseps(i1,i2,iph) = 0.d0
        end do
     end do
     EpsFile = 'opcons' // trim(adjustl(Components(iph))) // '.dat'
     if (verbose) print*, Components(iph), NumDens(iph), EpsFile
     call epsdb(iz(iph), thiseps(:,:,iph))
     if (write_opcons) call write_eps(iz(iph), thiseps(:,:,iph), EpsFile)
  end do

  NComps = nph + 1
  call AddEps(NComps, NumDens, thiseps, NDataTot, energy, loss)

  ! Open output file and write data.
  if (write_loss) then
     call OpenFl('loss.dat')
     call GetIOFileInfo('loss.dat', UnitNumber = iUnit)
     write(iUnit,'(A)') '# E(eV)    Loss'
     do i1 = 1, NDataTot
        write(iUnit,*), energy(i1), loss(i1)
     end do
     call CloseFl('loss.dat')
  end if

  deallocate(Components, rnrm, thisfile)

  !! sumrl, xNElec, gamma, and csumrl -- a bit cryptic
  sumrl = 1.d0
  xNElec = 1.d0
  inquire( file='exc.inp', exist=excinp )
  if (excinp) then
     open(unit=61, file='exc.inp', status='old')
     read(61,*) NPoles
     read(61,*) ch
     if (ch.eq.'y'.or.ch.eq.'Y') then
        eps0 = -1.d0
     else
        read(61,*) ch
        if(ch.eq.'n'.or.ch.eq.'N') then
           eps0 = -2.d0
        else
           read(61,*) eps0
        end if
     end if
     close(61)
  else
     print*, '# Enter number of poles:'
     read*, NPoles
     print*, 'Is this a metal? (y/n)'
     read*, ch
     if(ch.eq.'y'.or.ch.eq.'Y') then
        eps0 = -1.d0
     else
        print*, 'Would you like to set the dielectric constant? (y/n)'
        read*, ch
        if(ch.eq.'n'.or.ch.eq.'N') then
           eps0 = -2.d0
        else

           ! This input can be used to correct the dielectric constant,
           ! which is related to the inverse moment.
           ! Use eps0 = -2 to ignore this correction.
           print*, '# Enter dielectric constant: '
           read*, eps0
        end if
     end if
     if (verbose) print*, eps0
  end if

  gamma = 0.01
  csumrl= xNElec/sumrl
  do i1 = 1, NDataTot
     loss(i1) = loss(i1)*csumrl
  end do

  ! getomi finds poles and weights
  call getomi(energy, loss, NDataTot, NPoles, omi, g, Delta, eps0)

  if (write_exc) then
     open(unit=13,file='exc.dat',status='replace')
     write(13,'(A33,I4,A6)') '# Loss function represented with ', NPoles, ' poles'
     write(13,'(A23,f8.4)') '# Dielectric constant: ', eps0
     do i1 = 1, NPoles
        write(13,'(4f20.10)'), omi(i1), omi(i1)*gamma, g(i1), Delta(i1)
     end do
     close(13)
  end if

  !KJ 1-2012:
400 call par_barrier
  call par_end
  call WipeErrorfileAtFinish
  stop

end program opconsAt


! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module atomic_density
! ------------------------------------------------------------------------------
! Code area 5: Self consistency
! ------------------------------------------------------------------------------

!!****h* Conquest/atomic_density *
!!  NAME
!!   atomic_density
!!  PURPOSE
!!   Holds data structures for storing atomic densities and routines for reading
!!   or building these densities
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler and M.J.Gillan
!!  CREATION DATE
!!   24/09/2002
!!  MODIFICATION HISTORY
!!   12:15, 25/09/2002 mjg & drb
!!    Added rcut_dens - maximum atomic density table cutoff
!!   17:25, 2003/03/18 dave
!!    Added second derivative to radial density type and splining routine
!!   15:32, 08/04/2003 drb
!!    Added debugging statements
!!   17:28, 2003/06/10 tm
!!    spline problem fixed
!!   2008/02/04 08:21 dave
!!    Changed for output to file not stdout
!!   2008/05/23 ast
!!    Added timers
!!   2014/09/15 18:30 lat
!!    fixed call start/stop_timer to timer_module (not timer_stdlocks_module !)
!!   2015/11/09 08:31 dave with TM and NW from Mizuho
!!    Added new variables to radial_density type for neutral atom potential
!!   2016/01/07 13:41 dave
!!    Added calculation of delta for atomic density (makes more sense here than in make_neutral_atom !)
!!  SOURCE
!!
module atomic_density

  use datatypes
  use global_module,          only: io_lun
  use timer_stdclocks_module, only: tmr_std_allocation, tmr_std_chargescf
  use timer_module,           only: start_timer, stop_timer

  implicit none
  save

  type radial_density
     integer :: length
     real(double) :: cutoff
     real(double), pointer, dimension(:) :: table
     real(double), pointer, dimension(:) :: d2_table

     ! for Neutral atom potential
     real(double) :: delta
     integer :: k_length
     real(double) :: k_delta
     real(double), pointer, dimension(:) :: k_table
  end type radial_density

  type(radial_density), allocatable, dimension(:) :: atomic_density_table

  ! Maximum cutoff atomic on charge density tables
  real(double), allocatable, dimension(:) :: rcut_dens

!!***

contains

! -----------------------------------------------------------
! Subroutine make_atomic_density_from_paos
! -----------------------------------------------------------

!!****f* atomic_density/make_atomic_density_from_paos *
!!
!!  NAME
!!   make_atomic_density_from_paos
!!  USAGE
!!
!!  PURPOSE
!!   Makes atomic densities from PAOs read in
!!  INPUTS
!!
!!
!!  USES
!!   datatypes, GenComms, global_module, numbers, pao_format
!!  AUTHOR
!!   M.J.Gillan and D.R.Bowler
!!  CREATION DATE
!!   Summer 2002
!!  MODIFICATION HISTORY
!!   11:53, 24/09/2002 mjg & drb
!!    Incorporated into atomic_density
!!   12:35, 25/09/2002 mjg & drb
!!    Added rcut_dens to keep track of maximum cutoff on atomic charge density
!!   13:52, 29/07/2003 drb
!!    Changed iprint level at which 2001 point table printed out...
!!   2007/11/16 10:19 dave
!!    Changed linear interpolation to spline interpolation to fix forces problem
!!   2008/03/03 18:40 dave
!!    Changed float to real()
!!   2008/05/23 ast
!!    Added timers
!!   2017/03/23 drb
!!    Change to use delta from PAO structure, not calculate it
!!   2019/12/24 tsuyoshi
!!    Removed flag_aotmic_density_from_pao
!!    We don't need make_atomic_denisty_from_paos any more.
!!  SOURCE
!!
  subroutine make_atomic_density_from_paos(inode,ionode,n_species)

    use datatypes
    use GenComms, ONLY : cq_abort, gcopy
    use global_module, ONLY : iprint_SC, area_SC
    use numbers, ONLY : zero, one, four, pi, six
    use pao_format
    use memory_module, ONLY: reg_alloc_mem, type_dbl

    implicit none

    real(double), parameter :: one_over_four_pi = one/(four*pi)
    integer, intent(in) :: inode,ionode, n_species
    integer :: alls, i, nt, n_am, n_sp, n_zeta
    integer, parameter :: default_atomic_density_length = 2001
    real(double) :: cutoff, density_deltar, pao_deltar, r, rn_am, val
    real(double) :: a, b, c, d, r1, r2, r3, r4, rr

    call start_timer(tmr_std_chargescf)
    call start_timer(tmr_std_allocation)
    if(allocated(atomic_density_table)) then
       do i=1,size(atomic_density_table)
          deallocate(atomic_density_table(i)%table)
       end do
       deallocate(atomic_density_table)
    end if
    allocate(atomic_density_table(n_species),STAT = alls)
    if(alls /= 0) call cq_abort('make_atomic_density_from_paos: error allocating atomic_density_table ',n_species)

    allocate(rcut_dens(n_species),STAT=alls)
    call reg_alloc_mem(area_SC, n_species, type_dbl)
    if (alls /= 0) call cq_abort('make_atomic_density_from_paos: error allocating rcut_dens ',n_species)
    call stop_timer(tmr_std_allocation)
    rcut_dens = 0.0_double
    do n_sp = 1, n_species
       ! By default, use max PAO cut-off radius as density cut-off
       cutoff = zero
       do n_am = 0, pao(n_sp)%greatest_angmom
          if(pao(n_sp)%angmom(n_am)%n_zeta_in_angmom > 0) then
             do n_zeta = 1, pao(n_sp)%angmom(n_am)%n_zeta_in_angmom
                cutoff = max(cutoff,pao(n_sp)%angmom(n_am)%zeta(n_zeta)%cutoff)
             end do
          end if
       end do
       atomic_density_table(n_sp)%cutoff = cutoff
       rcut_dens(n_sp)=atomic_density_table(n_sp)%cutoff
       !if(atomic_density_table(n_sp)%cutoff>rcut_dens) rcut_dens=atomic_density_table(n_sp)%cutoff
       if((inode == ionode).and.(iprint_SC >= 2)) &
            &write(unit=io_lun,fmt='(/10x," radial cut-off to be used is taken to be max PAO cut-off radius for &
            &this species:",f12.6)') atomic_density_table(n_sp)%cutoff
       ! By default, use the parameter given above for length
       atomic_density_table(n_sp)%length = default_atomic_density_length
       ! Check for sensible length
       if(atomic_density_table(n_sp)%length < 2) &
            &call cq_abort('make_atomic_density_from_paos: table length must be >= 2',&
            &atomic_density_table(n_sp)%length)
       ! Allocate space for atomic density
       call start_timer(tmr_std_allocation)
       allocate(atomic_density_table(n_sp)%table(atomic_density_table(n_sp)%length),STAT = alls)
       if(alls /= 0) call cq_abort('make_atomic_density_from_paos: &
            &failed to allocate atomic_density_table(n_sp)%table()')
       call reg_alloc_mem(area_SC,atomic_density_table(n_sp)%length, type_dbl)
       call stop_timer(tmr_std_allocation)

       ! initiate to zero table of atomic density for current species and calculate table spacing
       do nt = 1, atomic_density_table(n_sp)%length
          atomic_density_table(n_sp)%table(nt) = zero
       end do
       ! Find spacing of table
       density_deltar = atomic_density_table(n_sp)%cutoff/&
            &real(atomic_density_table(n_sp)%length-1,double)
       atomic_density_table(n_sp)%delta = density_deltar
       ! Write out info and check angular momentum
       if((inode == ionode).and.(iprint_SC >= 2)) &
            write(unit=io_lun,fmt='(/10x," greatest ang. mom. for making density from PAOs:",i3)') &
            &pao(n_sp)%greatest_angmom
       if(pao(n_sp)%greatest_angmom < 0) &
            &call cq_abort('make_atomic_density_from_paos: greatest ang. mom. cannot be negative')
       ! Loop over angular momenta
       do n_am = 0, pao(n_sp)%greatest_angmom
          ! Check for zeta
          if(pao(n_sp)%angmom(n_am)%n_zeta_in_angmom > 0) then
             ! Loop over zetas
             do n_zeta = 1, pao(n_sp)%angmom(n_am)%n_zeta_in_angmom
                if(pao(n_sp)%angmom(n_am)%zeta(n_zeta)%length > 1) then
                   pao_deltar = pao(n_sp)%angmom(n_am)%zeta(n_zeta)%delta
                   do nt = 1, atomic_density_table(n_sp)%length
                      r = real(nt-1,double)*density_deltar
                      i = 1 + floor(r/pao_deltar)
                      if(i+1 <= pao(n_sp)%angmom(n_am)%zeta(n_zeta)%length) then
                         if(n_am /=0) then
                            rn_am = r**n_am
                         else
                            rn_am = one
                         endif
                         rr = real(i,double)*pao_deltar
                         a = (rr - r)/pao_deltar
                         b = one - a
                         c = a * ( a * a - one ) * pao_deltar * pao_deltar / six
                         d = b * ( b * b - one ) * pao_deltar * pao_deltar / six
                         r1 = pao(n_sp)%angmom(n_am)%zeta(n_zeta)%table(i)
                         r2 = pao(n_sp)%angmom(n_am)%zeta(n_zeta)%table(i+1)
                         r3 = pao(n_sp)%angmom(n_am)%zeta(n_zeta)%table2(i)
                         r4 = pao(n_sp)%angmom(n_am)%zeta(n_zeta)%table2(i+1)
                         val = a*r1 + b*r2 + c*r3 + d*r4
                         atomic_density_table(n_sp)%table(nt) = atomic_density_table(n_sp)%table(nt) + &
                              &one_over_four_pi * pao(n_sp)%angmom(n_am)%occ(n_zeta) * &
                              &(rn_am * val )**2
                      end if ! if(i+1<=pao(...)%length
                   end do ! do nt = atomic_density_table()%length
                end if ! if(pao(...)%length > 1
             end do ! do n_zeta = pao(...)%n_zeta_in_angmom
          end if ! pao(...)%n_zeta_in_angmom > 0
       end do ! n_am = pao(...)%greatest_angmom
       do nt = 1, atomic_density_table(n_sp)%length
          r = (nt-1)*density_deltar
          if(inode==ionode.AND.iprint_SC>3) write(io_lun,fmt='(10x,"Radial table: ",i5,2f15.8)') &
               nt,r,atomic_density_table(n_sp)%table(nt)
       end do
    end do ! n_sp = n_species
    do n_sp = 1,n_species
       if(inode == ionode.AND.iprint_SC>2) &
            write(io_lun,fmt='(10x,"Atomic density cutoff for species ",i4," : ",f15.8)') n_sp,rcut_dens(n_sp)
    end do
    call stop_timer(tmr_std_chargescf)
  end subroutine make_atomic_density_from_paos
!!***

! -----------------------------------------------------------
! Subroutine spline_atomic_density
! -----------------------------------------------------------

!!****f* atomic_density/spline_atomic_density *
!!
!!  NAME
!!   spline_atomic_density
!!  USAGE
!!
!!  PURPOSE
!!   Build spline tables for the radial tables of atomic densities
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   17:18, 2003/03/18 dave
!!  MODIFICATION HISTORY
!!   17:27, 2003/06/10 tm
!!    Fixed over-run problem with splining
!!   2008/05/23 ast
!!    Added timers
!!   2019/08/16 14:36 dave
!!    Removed dsplint and output of derivative (unnecessary)
!!  SOURCE
!!
  subroutine spline_atomic_density(n_species)

    use datatypes
    use numbers
    use splines, ONLY: spline
    use GenComms, ONLY: cq_abort, inode, ionode
    use global_module, ONLY: iprint_SC, area_SC
    use memory_module, ONLY: reg_alloc_mem, type_dbl

    implicit none

    ! Passed variables
    integer :: n_species
    ! Local variables

    integer :: i, n, stat

    real(double) :: d_end, d_origin, delta_r, r

    call start_timer(tmr_std_chargescf)
    ! loop over species and do the interpolation
    do n=1, n_species
       call start_timer(tmr_std_allocation)
       allocate(atomic_density_table(n)%d2_table(atomic_density_table(n)%length), STAT=stat)
       if(stat/=0) call cq_abort('spline_atomic_density: error allocating d2_table ! ',stat)
       call reg_alloc_mem(area_SC,atomic_density_table(n)%length, type_dbl)
       call stop_timer(tmr_std_allocation)
       ! do the splining for the table
       delta_r = atomic_density_table(n)%cutoff/real(atomic_density_table(n)%length-1,double)
       d_origin = (atomic_density_table(n)%table(2)- atomic_density_table(n)%table(1))/delta_r
       d_end = (atomic_density_table(n)%table(atomic_density_table(n)%length)- &
            atomic_density_table(n)%table(atomic_density_table(n)%length-1))/delta_r
       !d_origin = 1e30_double
       !d_end = 1e30_double
       call spline( atomic_density_table(n)%length, delta_r, atomic_density_table(n)%table(:),  &
            d_origin, d_end, atomic_density_table(n)%d2_table(:) )
       if(inode==ionode.AND.iprint_SC>3) then
          write(io_lun,fmt='(10x,"Atomic density for species ",i5)') n
          do i=1,atomic_density_table(n)%length
             r = real(i-1,double)*delta_r
             write(io_lun,fmt='(10x,2f20.12)') r,atomic_density_table(n)%table(i)
          end do
       end if
    end do
    call stop_timer(tmr_std_chargescf)
    return
  end subroutine spline_atomic_density
!!***

end module atomic_density