text:
C$Procedure ZZSPKZP0 ( S/P Kernel, easy position )

      SUBROUTINE ZZSPKZP0 ( TARG, ET, REF, ABCORR, OBS, PTARG, LT )

C$ Abstract
C
C     Return the position of a target body relative to an observing
C     body, optionally corrected for light time (planetary aberration)
C     and stellar aberration.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C     NAIF_IDS
C     FRAMES
C     TIME
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      IMPLICIT NONE
      INCLUDE               'frmtyp.inc'
      INCLUDE               'zzctr.inc'

      INTEGER               TARG
      DOUBLE PRECISION      ET
      CHARACTER*(*)         REF
      CHARACTER*(*)         ABCORR
      INTEGER               OBS
      DOUBLE PRECISION      PTARG    ( 3 )
      DOUBLE PRECISION      LT

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     TARG       I   Target body NAIF ID code.
C     ET         I   Observer epoch.
C     REF        I   Reference frame of output position vector.
C     ABCORR     I   Aberration correction flag.
C     OBS        I   Observing body NAIF ID code.
C     PTARG      O   Position of target.
C     LT         O   One way light time between observer and target.
C
C$ Detailed_Input
C
C     TARG        is the NAIF ID code for a target body.  The target
C                 and observer define a position vector which points
C                 from the observer to the target.
C
C     ET          is the ephemeris time, expressed as seconds past
C                 J2000 TDB, at which the position of the target body
C                 relative to the observer is to be computed.  ET
C                 refers to time at the observer's location.
C
C     REF         is the name of the reference frame relative to which
C                 the output position vector should be expressed. This
C                 may be any frame supported by the SPICE system,
C                 including built-in frames (documented in the Frames
C                 Required Reading) and frames defined by a loaded
C                 frame kernel (FK).
C
C                 When REF designates a non-inertial frame, the
C                 orientation of the frame is evaluated at an epoch
C                 dependent on the selected aberration correction. See
C                 the description of the output position vector PTARG
C                 for details.
C
C     ABCORR      indicates the aberration corrections to be applied to
C                 the position of the target body to account for
C                 one-way light time and stellar aberration.  See the
C                 discussion in the Particulars section for
C                 recommendations on how to choose aberration
C                 corrections.
C
C                 ABCORR may be any of the following:
C
C                    'NONE'     Apply no correction. Return the
C                               geometric position of the target body
C                               relative to the observer.
C
C                 The following values of ABCORR apply to the
C                 "reception" case in which photons depart from the
C                 target's location at the light-time corrected epoch
C                 ET-LT and *arrive* at the observer's location at ET:
C
C                    'LT'       Correct for one-way light time (also
C                               called "planetary aberration") using a
C                               Newtonian formulation. This correction
C                               yields the position of the target at
C                               the moment it emitted photons arriving
C                               at the observer at ET.
C
C                               The light time correction uses an
C                               iterative solution of the light time
C                               equation (see Particulars for details).
C                               The solution invoked by the 'LT' option
C                               uses one iteration.
C
C                    'LT+S'     Correct for one-way light time and
C                               stellar aberration using a Newtonian
C                               formulation. This option modifies the
C                               position obtained with the 'LT' option
C                               to account for the observer's velocity
C                               relative to the solar system
C                               barycenter. The result is the apparent
C                               position of the target---the position
C                               as seen by the observer.
C
C                    'CN'       Converged Newtonian light time
C                               correction. In solving the light time
C                               equation, the 'CN' correction iterates
C                               until the solution converges (three
C                               iterations on all supported platforms).
C                               Whether the 'CN+S' solution is
C                               substantially more accurate than the
C                               'LT' solution depends on the geometry
C                               of the participating objects and on the
C                               accuracy of the input data. In all
C                               cases this routine will execute more
C                               slowly when a converged solution is
C                               computed. See the Particulars section
C                               below for a discussion of precision of
C                               light time corrections.
C
C                    'CN+S'     Converged Newtonian light time
C                               correction and stellar aberration
C                               correction.
C
C
C                 The following values of ABCORR apply to the
C                 "transmission" case in which photons *depart* from
C                 the observer's location at ET and arrive at the
C                 target's location at the light-time corrected epoch
C                 ET+LT:
C
C                    'XLT'      "Transmission" case:  correct for
C                               one-way light time using a Newtonian
C                               formulation. This correction yields the
C                               position of the target at the moment it
C                               receives photons emitted from the
C                               observer's location at ET.
C
C                    'XLT+S'    "Transmission" case:  correct for
C                               one-way light time and stellar
C                               aberration using a Newtonian
C                               formulation. This option modifies the
C                               position obtained with the 'XLT' option
C                               to account for the observer's velocity
C                               relative to the solar system
C                               barycenter. The computed target
C                               position indicates the direction that
C                               photons emitted from the observer's
C                               location must be "aimed" to hit the
C                               target.
C
C                    'XCN'      "Transmission" case:  converged
C                               Newtonian light time correction.
C
C                    'XCN+S'    "Transmission" case:  converged
C                               Newtonian light time correction and
C                               stellar aberration correction.
C
C
C                 Neither special nor general relativistic effects are
C                 accounted for in the aberration corrections applied
C                 by this routine.
C
C                 Case and blanks are not significant in the string
C                 ABCORR.
C
C     OBS         is the NAIF ID code for the observing body.
C
C$ Detailed_Output
C
C     PTARG       is a Cartesian 3-vector representing the position of
C                 the target body relative to the specified observer.
C                 PTARG is corrected for the specified aberrations, and
C                 is expressed with respect to the reference frame
C                 specified by REF.  The three components of PTARG
C                 represent the x-, y- and z-components of the target's
C                 position.
C
C                 PTARG points from the observer's location at ET to
C                 the aberration-corrected location of the target.
C                 Note that the sense of this position vector is
C                 independent of the direction of radiation travel
C                 implied by the aberration correction.
C
C                 Units are always km.
C
C                 Non-inertial frames are treated as follows: letting
C                 LTCENT be the one-way light time between the observer
C                 and the 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     LT          is the one-way light time between the observer and
C                 target in seconds.  If the target position is
C                 corrected for aberrations, then LT is the one-way
C                 light time between the observer and the light time
C                 corrected target location.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If name of target or observer cannot be translated to its
C        NAIF ID code, the error SPICE(IDCODENOTFOUND) is signaled.
C
C     2) If the reference frame REF is not a recognized reference
C        frame the error 'SPICE(UNKNOWNFRAME)' is signaled.
C
C     3) If the loaded kernels provide insufficient data to
C        compute the requested position vector, the deficiency will
C        be diagnosed by a routine in the call tree of this routine.
C
C     4) If an error occurs while reading an SPK or other kernel file,
C        the error  will be diagnosed by a routine in the call tree
C        of this routine.
C
C     5) If any of the required attributes of the reference frame REF
C        cannot be determined, 'SPICE(UNKNOWNFRAME2)' is signaled.
C
C$ Files
C
C     This routine computes positions using SPK files that have been
C     loaded into the SPICE system, normally via the kernel loading
C     interface routine FURNSH. See the routine FURNSH and the SPK
C     and KERNEL Required Reading for further information on loading
C     (and unloading) kernels.
C
C     If the output position PTARG is to be expressed relative to a
C     non-inertial frame, or if any of the ephemeris data used to
C     compute PTARG are expressed relative to a non-inertial frame in
C     the SPK files providing those data, additional kernels may be
C     needed to enable the reference frame transformations required to
C     compute the position.  Normally these additional kernels are PCK
C     files or frame kernels.  Any such kernels must already be loaded
C     at the time this routine is called.
C
C$ Particulars
C
C     This routine is part of the user interface to the SPICE ephemeris
C     system.  It allows you to retrieve position information for any
C     ephemeris object relative to any other in a reference frame that
C     is convenient for further computations.
C
C     Aberration corrections
C     ======================
C
C     In space science or engineering applications one frequently
C     wishes to know where to point a remote sensing instrument, such
C     as an optical camera or radio antenna, in order to observe or
C     otherwise receive radiation from a target.  This pointing problem
C     is complicated by the finite speed of light:  one needs to point
C     to where the target appears to be as opposed to where it actually
C     is at the epoch of observation.  We use the adjectives
C     "geometric," "uncorrected," or "true" to refer to an actual
C     position or state of a target at a specified epoch.  When a
C     geometric position or state vector is modified to reflect how it
C     appears to an observer, we describe that vector by any of the
C     terms "apparent," "corrected," "aberration corrected," or "light
C     time and stellar aberration corrected." The SPICE Toolkit can
C     correct for two phenomena affecting the apparent location of an
C     object:  one-way light time (also called "planetary aberration")
C     and stellar aberration.
C
C     One-way light time
C     ------------------
C
C     Correcting for one-way light time is done by computing, given an
C     observer and observation epoch, where a target was when the
C     observed photons departed the target's location.  The vector from
C     the observer to this computed target location is called a "light
C     time corrected" vector.  The light time correction depends on the
C     motion of the target relative to the solar system barycenter, but
C     it is independent of the velocity of the observer relative to the
C     solar system barycenter. Relativistic effects such as light
C     bending and gravitational delay are not accounted for in the
C     light time correction performed by this routine.
C
C     Stellar aberration
C     ------------------
C
C     The velocity of the observer also affects the apparent location
C     of a target:  photons arriving at the observer are subject to a
C     "raindrop effect" whereby their velocity relative to the observer
C     is, using a Newtonian approximation, the photons' velocity
C     relative to the solar system barycenter minus the velocity of the
C     observer relative to the solar system barycenter.  This effect is
C     called "stellar aberration."  Stellar aberration is independent
C     of the velocity of the target.  The stellar aberration formula
C     used by this routine does not include (the much smaller)
C     relativistic effects.
C
C     Stellar aberration corrections are applied after light time
C     corrections:  the light time corrected target position vector is
C     used as an input to the stellar aberration correction.
C
C     When light time and stellar aberration corrections are both
C     applied to a geometric position vector, the resulting position
C     vector indicates where the target "appears to be" from the
C     observer's location.
C
C     As opposed to computing the apparent position of a target, one
C     may wish to compute the pointing direction required for
C     transmission of photons to the target.  This also requires
C     correction of the geometric target position for the effects of
C     light time and stellar aberration, but in this case the
C     corrections are computed for radiation traveling *from* the
C     observer to the target.
C
C     The "transmission" light time correction yields the target's
C     location as it will be when photons emitted from the observer's
C     location at ET arrive at the target.  The transmission stellar
C     aberration correction is the inverse of the traditional stellar
C     aberration correction:  it indicates the direction in which
C     radiation should be emitted so that, using a Newtonian
C     approximation, the sum of the velocity of the radiation relative
C     to the observer and of the observer's velocity, relative to the
C     solar system barycenter, yields a velocity vector that points in
C     the direction of the light time corrected position of the target.
C
C     One may object to using the term "observer" in the transmission
C     case, in which radiation is emitted from the observer's location.
C     The terminology was retained for consistency with earlier
C     documentation.
C
C     Below, we indicate the aberration corrections to use for some
C     common applications:
C
C        1) Find the apparent direction of a target for a remote-sensing
C           observation.
C
C              Use 'LT+S' or 'CN+S: apply both light time and stellar
C              aberration corrections.
C
C           Note that using light time corrections alone ('LT' or 'CN')
C           is generally not a good way to obtain an approximation to
C           an apparent target vector: since light time and stellar
C           aberration corrections often partially cancel each other,
C           it may be more accurate to use no correction at all than to
C           use light time alone.
C
C
C        2) Find the corrected pointing direction to radiate a signal
C           to a target. This computation is often applicable for
C           implementing communications sessions.
C
C              Use 'XLT+S' or 'XCN+S: apply both light time and stellar
C              aberration corrections for transmission.
C
C
C        3) Compute the apparent position of a target body relative
C           to a star or other distant object.
C
C              Use 'LT', 'CN', 'LT+S', or 'CN+S' as needed to match the
C              correction applied to the position of the distant
C              object. For example, if a star position is obtained from
C              a catalog, the position vector may not be corrected for
C              stellar aberration. In this case, to find the angular
C              separation of the star and the limb of a planet, the
C              vector from the observer to the planet should be
C              corrected for light time but not stellar aberration.
C
C
C        4) Obtain an uncorrected position vector derived directly from
C           data in an SPK file.
C
C              Use 'NONE'.
C
C
C        5) Use a geometric position vector as a low-accuracy estimate
C           of the apparent position for an application where execution
C           speed is critical.
C
C              Use 'NONE'.
C
C
C        6) While this routine cannot perform the relativistic
C           aberration corrections required to compute positions
C           with the highest possible accuracy, it can supply the
C           geometric positions required as inputs to these
C           computations.
C
C              Use 'NONE', then apply high-accuracy aberration
C              corrections (not available in the SPICE Toolkit).
C
C
C     Below, we discuss in more detail how the aberration corrections
C     applied by this routine are computed.
C
C        Geometric case
C        ==============
C
C        SPKEZP begins by computing the geometric position T(ET) of the
C        target body relative to the solar system barycenter (SSB).
C        Subtracting the geometric position of the observer O(ET) gives
C        the geometric position of the target body relative to the
C        observer. The one-way light time, LT, is given by
C
C                  | T(ET) - O(ET) |
C           LT = -------------------
C                          c
C
C        The geometric relationship between the observer, target, and
C        solar system barycenter is as shown:
C
C
C           SSB ---> O(ET)
C            |      /
C            |     /
C            |    /
C            |   /  T(ET) - O(ET)
C            V  V
C           T(ET)
C
C
C        The returned position vector is
C
C           T(ET) - O(ET)
C
C
C
C        Reception case
C        ==============
C
C        When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is selected
C        for ABCORR, SPKEZP computes the position of the target body at
C        epoch ET-LT, where LT is the one-way light time.  Let T(t) and
C        O(t) represent the positions of the target and observer
C        relative to the solar system barycenter at time t; then LT is
C        the solution of the light-time equation
C
C                  | T(ET-LT) - O(ET) |
C           LT = ------------------------                            (1)
C                           c
C
C        The ratio
C
C            | T(ET) - O(ET) |
C          ---------------------                                     (2)
C                    c
C
C        is used as a first approximation to LT; inserting (2) into the
C        right hand side of the light-time equation (1) yields the
C        "one-iteration" estimate of the one-way light time ("LT").
C        Repeating the process until the estimates of LT converge
C        yields the "converged Newtonian" light time estimate ("CN").
C
C        Subtracting the geometric position of the observer O(ET) gives
C        the position of the target body relative to the observer:
C        T(ET-LT) - O(ET).
C
C           SSB ---> O(ET)
C            | \     |
C            |  \    |
C            |   \   | T(ET-LT) - O(ET)
C            |    \  |
C            V     V V
C           T(ET)  T(ET-LT)
C
C        The light time corrected position vector is
C
C           T(ET-LT) - O(ET)
C
C        If correction for stellar aberration is requested, the target
C        position is rotated toward the solar system barycenter-
C        relative velocity vector of the observer.  The rotation is
C        computed as follows:
C
C           Let r be the light time corrected vector from the observer
C           to the object, and v be the velocity of the observer with
C           respect to the solar system barycenter. Let w be the angle
C           between them. The aberration angle phi is given by
C
C              sin(phi) = v sin(w) / c
C
C           Let h be the vector given by the cross product
C
C              h = r X v
C
C           Rotate r by phi radians about h to obtain the apparent
C           position of the object.
C
C
C        Transmission case
C        ==================
C
C        When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' is
C        selected, SPKEZP computes the position of the target body T at
C        epoch ET+LT, where LT is the one-way light time.  LT is the
C        solution of the light-time equation
C
C                  | T(ET+LT) - O(ET) |
C           LT = ------------------------                            (3)
C                            c
C
C        Subtracting the geometric position of the observer, O(ET),
C        gives the position of the target body relative to the
C        observer: T(ET-LT) - O(ET).
C
C                   SSB --> O(ET)
C                  / |    *
C                 /  |  *  T(ET+LT) - O(ET)
C                /   |*
C               /   *|
C              V  V  V
C          T(ET+LT)  T(ET)
C
C        The light-time corrected position vector is
C
C           T(ET+LT) - O(ET)
C
C        If correction for stellar aberration is requested, the target
C        position is rotated away from the solar system barycenter-
C        relative velocity vector of the observer. The rotation is
C        computed as in the reception case, but the sign of the
C        rotation angle is negated.
C
C
C     Precision of light time corrections
C     ===================================
C
C        Corrections using one iteration of the light time solution
C        ----------------------------------------------------------
C
C        When the requested aberration correction is 'LT', 'LT+S',
C        'XLT', or 'XLT+S', only one iteration is performed in the
C        algorithm used to compute LT.
C
C        The relative error in this computation
C
C           | LT_ACTUAL - LT_COMPUTED |  /  LT_ACTUAL
C
C        is at most
C
C            (V/C)**2
C           ----------
C            1 - (V/C)
C
C        which is well approximated by (V/C)**2, where V is the
C        velocity of the target relative to an inertial frame and C is
C        the speed of light.
C
C        For nearly all objects in the solar system V is less than 60
C        km/sec. The value of C is ~300000 km/sec. Thus the
C        one-iteration solution for LT has a potential relative error
C        of not more than 4e-8. This is a potential light time error of
C        approximately 2e-5 seconds per astronomical unit of distance
C        separating the observer and target. Given the bound on V cited
C        above:
C
C           As long as the observer and target are separated by less
C           than 50 astronomical units, the error in the light time
C           returned using the one-iteration light time corrections is
C           less than 1 millisecond.
C
C           The magnitude of the corresponding position error, given
C           the above assumptions, may be as large as (V/C)**2 * the
C           distance between the observer and the uncorrected target
C           position: 300 km or equivalently 6 km/AU.
C
C        In practice, the difference between positions obtained using
C        one-iteration and converged light time is usually much smaller
C        than the value computed above and can be insignificant. For
C        example, for the spacecraft Mars Reconnaissance Orbiter and
C        Mars Express, the position error for the one-iteration light
C        time correction, applied to the spacecraft-to-Mars center
C        vector, is at the 1 cm level.
C
C        Comparison of results obtained using the one-iteration and
C        converged light time solutions is recommended when adequacy of
C        the one-iteration solution is in doubt.
C
C
C        Converged corrections
C        ---------------------
C
C        When the requested aberration correction is 'CN', 'CN+S',
C        'XCN', or 'XCN+S', as many iterations as are required for
C        convergence are performed in the computation of LT. Usually
C        the solution is found after three iterations. The relative
C        error present in this case is at most
C
C            (V/C)**4
C           ----------
C            1 - (V/C)
C
C        which is well approximated by (V/C)**4.
C
C           The precision of this computation (ignoring round-off
C           error) is better than 4e-11 seconds for any pair of objects
C           less than 50 AU apart, and having speed relative to the
C           solar system barycenter less than 60 km/s.
C
C           The magnitude of the corresponding position error, given
C           the above assumptions, may be as large as (V/C)**4 * the
C           distance between the observer and the uncorrected target
C           position: 1.2 cm at 50 AU or equivalently 0.24 mm/AU.
C
C        However, to very accurately model the light time between
C        target and observer one must take into account effects due to
C        general relativity. These may be as high as a few hundredths
C        of a millisecond for some objects.
C
C
C     Relativistic Corrections
C     =========================
C
C     This routine does not attempt to perform either general or
C     special relativistic corrections in computing the various
C     aberration corrections.  For many applications relativistic
C     corrections are not worth the expense of added computation
C     cycles.  If however, your application requires these additional
C     corrections we suggest you consult the astronomical almanac (page
C     B36) for a discussion of how to carry out these corrections.
C
C
C$ Examples
C
C     1)  Load a planetary ephemeris SPK, then look up a series of
C         geometric positions of the moon relative to the earth,
C         referenced to the J2000 frame.
C
C
C               IMPLICIT NONE
C         C
C         C     Local constants
C         C
C               CHARACTER*(*)         FRAME
C               PARAMETER           ( FRAME  = 'J2000' )
C
C               CHARACTER*(*)         ABCORR
C               PARAMETER           ( ABCORR = 'NONE' )
C
C         C
C         C     The name of the SPK file shown here is fictitious;
C         C     you must supply the name of an SPK file available
C         C     on your own computer system.
C         C
C               CHARACTER*(*)         SPK
C               PARAMETER           ( SPK    = 'planet.bsp' )
C
C         C
C         C     ET0 represents the date 2000 Jan 1 12:00:00 TDB.
C         C
C               DOUBLE PRECISION      ET0
C               PARAMETER           ( ET0    = 0.0D0 )
C
C         C
C         C     Use a time step of 1 hour; look up 100 positions.
C         C
C               DOUBLE PRECISION      STEP
C               PARAMETER           ( STEP   = 3600.0D0 )
C
C               INTEGER               MAXITR
C               PARAMETER           ( MAXITR = 100 )
C
C         C
C         C     The NAIF IDs of the earth and moon are 399 and 301
C         C     respectively.
C         C
C               INTEGER               OBSRVR
C               PARAMETER           ( OBSRVR = 399 )
C
C               INTEGER               TARGET
C               PARAMETER           ( TARGET = 301 )
C
C         C
C         C     Local variables
C         C
C               DOUBLE PRECISION      ET
C               DOUBLE PRECISION      LT
C               DOUBLE PRECISION      POS ( 3 )
C
C               INTEGER               I
C
C         C
C         C     Load the SPK file.
C         C
C               CALL FURNSH ( SPK )
C
C         C
C         C     Step through a series of epochs, looking up a
C         C     position vector at each one.
C         C
C               DO I = 1, MAXITR
C
C                  ET = ET0 + (I-1)*STEP
C
C                  CALL SPKEZP ( TARGET, ET, FRAME, ABCORR, OBSRVR,
C              .                 POS,    LT                        )
C
C                  WRITE (*,*) 'ET = ', ET
C                  WRITE (*,*) 'J2000 x-position (km):   ', POS(1)
C                  WRITE (*,*) 'J2000 y-position (km):   ', POS(2)
C                  WRITE (*,*) 'J2000 z-position (km):   ', POS(3)
C                  WRITE (*,*) ' '
C
C               END DO
C
C               END
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     SPK Required Reading.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     B.V. Semenov    (JPL)
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.2.0, 03-JUL-2014 (NJB) (BVS)
C
C        Discussion of light time corrections was updated. Assertions
C        that converged light time corrections are unlikely to be
C        useful were removed.
C
C     Last update was 23-SEP-2013 (BVS)
C
C        Bug fix: added a check and an exception for the FOUND flag
C        returned by FRINFO.
C
C        Updated to save the input frame name and POOL state counter
C        and to do frame name-ID conversion only if the counter has
C        changed.
C
C-    SPICELIB Version 3.1.1, 04-APR-2008 (NJB)
C
C        Corrected minor error in description of XLT+S aberration
C        correction.
C
C-    SPICELIB Version 3.1.0, 06-JAN-2005 (NJB)
C
C        Tests of routine FAILED() were added.
C
C-    SPICELIB Version 3.0.3, 12-DEC-2004 (NJB)
C
C        Minor header error was corrected.
C
C-    SPICELIB Version 3.0.2, 20-OCT-2003 (EDW)
C
C        Added mention that LT returns in seconds.
C
C-    SPICELIB Version 3.0.1, 29-JUL-2003 (NJB) (CHA)
C
C        Various minor header changes were made to improve clarity.
C
C-    SPICELIB Version 3.0.0, 31-DEC-2001 (NJB)
C
C        Updated to handle aberration corrections for transmission
C        of radiation.  Formerly, only the reception case was
C        supported.  The header was revised and expanded to explain
C        the functionality of this routine in more detail.
C
C-    SPICELIB Version 1.0.0, 03-MAR-1999 (WLT)
C
C-&

C$ Index_Entries
C
C     using body names get position relative to an observer
C     get position relative observer corrected for aberrations
C     read ephemeris data
C     read trajectory data
C
C-&

C$ Revisions
C
C-    SPICELIB Version 4.1.0, 05-JAN-2005 (NJB)
C
C        Tests of routine FAILED() were added.  The new checks
C        are intended to prevent arithmetic operations from
C        being performed with uninitialized or invalid data.
C
C-&

C
C
C     SPICELIB functions
C
      INTEGER               LTRIM

      LOGICAL               EQCHR
      LOGICAL               EQSTR
      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local parameters
C
      CHARACTER*(*)         RNAME
      PARAMETER           ( RNAME  =  'ZZSPKZP0' )

C
C     Saved frame name length.
C
      INTEGER               FRNMLN
      PARAMETER           ( FRNMLN = 32 )

C
C     Local variables
C
      DOUBLE PRECISION      LTCENT
      DOUBLE PRECISION      SOBS     ( 6    )
      DOUBLE PRECISION      POSTN    ( 3    )
      DOUBLE PRECISION      TEMP     ( 3    )
      DOUBLE PRECISION      XFORM    ( 3, 3 )

      INTEGER               CENTER
      INTEGER               FJ2000
      INTEGER               I
      INTEGER               REQFRM
      INTEGER               TYPE
      INTEGER               TYPEID

      LOGICAL               FIRST
      LOGICAL               FOUND
      LOGICAL               XMIT

C
C     Saved frame name/ID item declarations.
C
      INTEGER               SVCTR1 ( CTRSIZ )
      CHARACTER*(FRNMLN)    SVREF
      INTEGER               SVREQF

C
C     Saved variables
C
      SAVE

C
C     Initial values
C
      DATA                  FIRST /.TRUE./

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( RNAME )
      END IF

C
C     Get the frame id for J2000 on the first call to this routine.
C
      IF ( FIRST ) THEN

         CALL NAMFRM( 'J2000', FJ2000 )

C
C        Initialize counter.
C
         CALL ZZCTRUIN( SVCTR1 )

         FIRST = .FALSE.

      END IF

C
C     Decide whether the aberration correction is for received or
C     transmitted radiation.
C
      I    = LTRIM(ABCORR)
      XMIT = EQCHR ( ABCORR(I:I),  'X' )

C
C     If we only want geometric positions, then compute just that.
C
C     Otherwise, compute the state of the observer relative to
C     the SSB.  Then feed that position into SPKAPO to compute the
C     apparent position of the target body relative to the observer
C     with the requested aberration corrections.
C
      IF ( EQSTR( ABCORR, 'NONE' ) ) THEN

         CALL ZZSPKGP0 ( TARG, ET, REF, OBS, PTARG, LT )

      ELSE
C
C        Get the auxiliary information about the requested output
C        frame.
C
         CALL ZZNAMFRM ( SVCTR1, SVREF, SVREQF, REF, REQFRM )

         IF ( REQFRM .EQ. 0 ) THEN
            CALL SETMSG ( 'The requested output frame ''#'' is '
     .      //            'not recognized by the reference frame '
     .      //            'subsystem. Please check that the '
     .      //            'appropriate kernels have been loaded '
     .      //            'and that you have correctly entered '
     .      //            'the name of the output frame. ' )
            CALL ERRCH  ( '#', REF )
            CALL SIGERR ( 'SPICE(UNKNOWNFRAME)'  )
            CALL CHKOUT ( RNAME )
            RETURN

         END IF

         CALL FRINFO ( REQFRM, CENTER, TYPE, TYPEID, FOUND )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

         IF ( .NOT. FOUND ) THEN

            CALL SETMSG ( 'The requested output frame ''#'' is '
     .      //            'not recognized by the reference frame '
     .      //            'subsystem. Please check that the '
     .      //            'appropriate kernels have been loaded '
     .      //            'and that you have correctly entered '
     .      //            'the name of the output frame. ' )
            CALL ERRCH  ( '#',  REF )
            CALL SIGERR ( 'SPICE(UNKNOWNFRAME2)' )
            CALL CHKOUT ( RNAME )

            RETURN

         END IF

C
C        If we are dealing with an inertial frame, we can simply
C        call SPKSSB, SPKAPO and return.
C
         IF ( TYPE .EQ. INERTL ) THEN

            CALL ZZSPKSB0 ( OBS,  ET, REF, SOBS )
            CALL ZZSPKPA0 ( TARG, ET, REF, SOBS, ABCORR, PTARG, LT )
            CALL CHKOUT ( RNAME )
            RETURN

         END IF

C
C        Still here?
C
C        We are dealing with a non-inertial frame.  But we need to
C        do light time and stellar aberration in an inertial frame.
C        Get the "apparent" position of TARG in the intermediary
C        inertial reference frame J2000.
C
C        We also need the light time to the center of the frame.
C
         CALL ZZSPKSB0 ( OBS,  ET, 'J2000', SOBS )
         CALL ZZSPKPA0 ( TARG, ET, 'J2000', SOBS, ABCORR, POSTN, LT )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

         IF ( CENTER .EQ. OBS ) THEN
            LTCENT = 0.0D0
         ELSE IF ( CENTER .EQ. TARG ) THEN
            LTCENT = LT
         ELSE
            CALL ZZSPKPA0 ( CENTER, ET, 'J2000', SOBS, ABCORR, TEMP,
     .                      LTCENT )
         END IF

C
C        If something went wrong (like we couldn't get the position of
C        the center relative to the observer) now it is time to quit.
C
         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

C
C        If the aberration corrections are for transmission, negate
C        the light time, since we wish to compute the orientation
C        of the non-inertial frame at an epoch later than ET by
C        the one-way light time.
C
         IF ( XMIT ) THEN
            LTCENT = -LTCENT
         END IF

C
C        Get the rotation from J2000 to the requested frame
C        and convert the position.
C
         CALL ZZREFCH0 ( FJ2000, REQFRM, ET-LTCENT, XFORM )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( RNAME )
            RETURN
         END IF

         CALL MXV    ( XFORM,  POSTN,             PTARG )

      END IF

      CALL CHKOUT ( RNAME )
      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


!*==sgelss.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SGELSS solves overdetermined or underdetermined systems for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGELSS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
!                          WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
!       REAL               RCOND
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGELSS computes the minimum norm solution to a real linear least
!> squares problem:
!>
!> Minimize 2-norm(| b - A*x |).
!>
!> using the singular value decomposition (SVD) of A. A is an M-by-N
!> matrix which may be rank-deficient.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
!> X.
!>
!> The effective rank of A is determined by treating as zero those
!> singular values which are less than RCOND times the largest singular
!> value.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X. NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the first min(m,n) rows of A are overwritten with
!>          its right singular vectors, stored rowwise.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>          On entry, the M-by-NRHS right hand side matrix B.
!>          On exit, B is overwritten by the N-by-NRHS solution
!>          matrix X.  If m >= n and RANK = n, the residual
!>          sum-of-squares for the solution in the i-th column is given
!>          by the sum of squares of elements n+1:m in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,max(M,N)).
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL array, dimension (min(M,N))
!>          The singular values of A in decreasing order.
!>          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!> \endverbatim
!>
!> \param[in] RCOND
!> \verbatim
!>          RCOND is REAL
!>          RCOND is used to determine the effective rank of A.
!>          Singular values S(i) <= RCOND*S(1) are treated as zero.
!>          If RCOND < 0, machine precision is used instead.
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>          The effective rank of A, i.e., the number of singular values
!>          which are greater than RCOND*S(1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= 1, and also:
!>          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the algorithm for computing the SVD failed to converge;
!>                if INFO = i, i off-diagonal elements of an intermediate
!>                bidiagonal form did not converge to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGEsolve
!
!  =====================================================================
      SUBROUTINE SGELSS(M,N,Nrhs,A,Lda,B,Ldb,S,Rcond,Rank,Work,Lwork,   &
     &                  Info)
      IMPLICIT NONE
!*--SGELSS176
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs , Rank
      REAL Rcond
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , B(Ldb,*) , S(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER bdspac , bl , chunk , i , iascl , ibscl , ie , il , itau ,&
     &        itaup , itauq , iwork , ldwork , maxmn , maxwrk , minmn , &
     &        minwrk , mm , mnthr
      INTEGER lwork_sgeqrf , lwork_sormqr , lwork_sgebrd ,              &
     &        lwork_sormbr , lwork_sorgbr , lwork_sormlq
      REAL anrm , bignum , bnrm , eps , sfmin , smlnum , thr
!     ..
!     .. Local Arrays ..
      REAL dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL SBDSQR , SCOPY , SGEBRD , SGELQF , SGEMM , SGEMV ,       &
     &         SGEQRF , SLABAD , SLACPY , SLASCL , SLASET , SORGBR ,    &
     &         SORMBR , SORMLQ , SORMQR , SRSCL , XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      REAL SLAMCH , SLANGE
      EXTERNAL ILAENV , SLAMCH , SLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      minmn = MIN(M,N)
      maxmn = MAX(M,N)
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,maxmn) ) THEN
         Info = -7
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF ( minmn>0 ) THEN
            mm = M
            mnthr = ILAENV(6,'SGELSS',' ',M,N,Nrhs,-1)
            IF ( M>=N .AND. M>=mnthr ) THEN
!
!              Path 1a - overdetermined, with many more rows than
!                        columns
!
!              Compute space needed for SGEQRF
               CALL SGEQRF(M,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_sgeqrf = dum(1)
!              Compute space needed for SORMQR
               CALL SORMQR('L','T',M,Nrhs,N,A,Lda,dum(1),B,Ldb,dum(1),  &
     &                     -1,Info)
               lwork_sormqr = dum(1)
               mm = N
               maxwrk = MAX(maxwrk,N+lwork_sgeqrf)
               maxwrk = MAX(maxwrk,N+lwork_sormqr)
            ENDIF
            IF ( M>=N ) THEN
!
!              Path 1 - overdetermined or exactly determined
!
!              Compute workspace needed for SBDSQR
!
               bdspac = MAX(1,5*N)
!              Compute space needed for SGEBRD
               CALL SGEBRD(mm,N,A,Lda,S,dum(1),dum(1),dum(1),dum(1),-1, &
     &                     Info)
               lwork_sgebrd = dum(1)
!              Compute space needed for SORMBR
               CALL SORMBR('Q','L','T',mm,Nrhs,N,A,Lda,dum(1),B,Ldb,    &
     &                     dum(1),-1,Info)
               lwork_sormbr = dum(1)
!              Compute space needed for SORGBR
               CALL SORGBR('P',N,N,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_sorgbr = dum(1)
!              Compute total workspace needed
               maxwrk = MAX(maxwrk,3*N+lwork_sgebrd)
               maxwrk = MAX(maxwrk,3*N+lwork_sormbr)
               maxwrk = MAX(maxwrk,3*N+lwork_sorgbr)
               maxwrk = MAX(maxwrk,bdspac)
               maxwrk = MAX(maxwrk,N*Nrhs)
               minwrk = MAX(3*N+mm,3*N+Nrhs,bdspac)
               maxwrk = MAX(minwrk,maxwrk)
            ENDIF
            IF ( N>M ) THEN
!
!              Compute workspace needed for SBDSQR
!
               bdspac = MAX(1,5*M)
               minwrk = MAX(3*M+Nrhs,3*M+N,bdspac)
               IF ( N>=mnthr ) THEN
!
!                 Path 2a - underdetermined, with many more columns
!                 than rows
!
!                 Compute space needed for SGEBRD
                  CALL SGEBRD(M,M,A,Lda,S,dum(1),dum(1),dum(1),dum(1),  &
     &                        -1,Info)
                  lwork_sgebrd = dum(1)
!                 Compute space needed for SORMBR
                  CALL SORMBR('Q','L','T',M,Nrhs,N,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_sormbr = dum(1)
!                 Compute space needed for SORGBR
                  CALL SORGBR('P',M,M,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_sorgbr = dum(1)
!                 Compute space needed for SORMLQ
                  CALL SORMLQ('L','T',N,Nrhs,M,A,Lda,dum(1),B,Ldb,dum(1)&
     &                        ,-1,Info)
                  lwork_sormlq = dum(1)
!                 Compute total workspace needed
                  maxwrk = M + M*ILAENV(1,'SGELQF',' ',M,N,-1,-1)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sgebrd)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sormbr)
                  maxwrk = MAX(maxwrk,M*M+4*M+lwork_sorgbr)
                  maxwrk = MAX(maxwrk,M*M+M+bdspac)
                  IF ( Nrhs>1 ) THEN
                     maxwrk = MAX(maxwrk,M*M+M+M*Nrhs)
                  ELSE
                     maxwrk = MAX(maxwrk,M*M+2*M)
                  ENDIF
                  maxwrk = MAX(maxwrk,M+lwork_sormlq)
               ELSE
!
!                 Path 2 - underdetermined
!
!                 Compute space needed for SGEBRD
                  CALL SGEBRD(M,N,A,Lda,S,dum(1),dum(1),dum(1),dum(1),  &
     &                        -1,Info)
                  lwork_sgebrd = dum(1)
!                 Compute space needed for SORMBR
                  CALL SORMBR('Q','L','T',M,Nrhs,M,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_sormbr = dum(1)
!                 Compute space needed for SORGBR
                  CALL SORGBR('P',M,N,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_sorgbr = dum(1)
                  maxwrk = 3*M + lwork_sgebrd
                  maxwrk = MAX(maxwrk,3*M+lwork_sormbr)
                  maxwrk = MAX(maxwrk,3*M+lwork_sorgbr)
                  maxwrk = MAX(maxwrk,bdspac)
                  maxwrk = MAX(maxwrk,N*Nrhs)
               ENDIF
            ENDIF
            maxwrk = MAX(minwrk,maxwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGELSS',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) THEN
         Rank = 0
         RETURN
      ENDIF
!
!     Get machine parameters
!
      eps = SLAMCH('P')
      sfmin = SLAMCH('S')
      smlnum = sfmin/eps
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = SLANGE('M',M,N,A,Lda,Work)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL SLASET('F',MAX(M,N),Nrhs,ZERO,ZERO,B,Ldb)
         CALL SLASET('F',minmn,1,ZERO,ZERO,S,minmn)
         Rank = 0
         GOTO 100
      ENDIF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = SLANGE('M',M,Nrhs,B,Ldb,Work)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,bnrm,smlnum,M,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,bnrm,bignum,M,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
!     Overdetermined case
!
      IF ( M>=N ) THEN
!
!        Path 1 - overdetermined or exactly determined
!
         mm = M
         IF ( M>=mnthr ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns
!
            mm = N
            itau = 1
            iwork = itau + N
!
!           Compute A=Q*R
!           (Workspace: need 2*N, prefer N+N*NB)
!
            CALL SGEQRF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1, &
     &                  Info)
!
!           Multiply B by transpose(Q)
!           (Workspace: need N+NRHS, prefer N+NRHS*NB)
!
            CALL SORMQR('L','T',M,Nrhs,N,A,Lda,Work(itau),B,Ldb,        &
     &                  Work(iwork),Lwork-iwork+1,Info)
!
!           Zero out below R
!
            IF ( N>1 ) CALL SLASET('L',N-1,N-1,ZERO,ZERO,A(2,1),Lda)
         ENDIF
!
         ie = 1
         itauq = ie + N
         itaup = itauq + N
         iwork = itaup + N
!
!        Bidiagonalize R in A
!        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
!
         CALL SGEBRD(mm,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of R
!        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
!
         CALL SORMBR('Q','L','T',mm,Nrhs,N,A,Lda,Work(itauq),B,Ldb,     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in A
!        (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
!
         CALL SORGBR('P',N,N,N,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         iwork = ie + N
!
!        Perform bidiagonal QR iteration
!          multiply B by transpose of left singular vectors
!          compute right singular vectors in A
!        (Workspace: need BDSPAC)
!
         CALL SBDSQR('U',N,N,0,Nrhs,S,Work(ie),A,Lda,dum,1,B,Ldb,       &
     &               Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , N
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors
!        (Workspace: need N, prefer N*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',N,Nrhs,N,ONE,A,Lda,B,Ldb,ZERO,Work,Ldb)
            CALL SLACPY('G',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',N,bl,N,ONE,A,Lda,B(1,i),Ldb,ZERO,Work,&
     &                    N)
               CALL SLACPY('G',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',N,N,ONE,A,Lda,B,1,ZERO,Work,1)
            CALL SCOPY(N,Work,1,B,1)
         ENDIF
!
      ELSEIF ( N>=mnthr .AND. Lwork>=4*M+M*M+MAX(M,2*M-4,Nrhs,N-3*M) )  &
     &         THEN
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm
!
         ldwork = M
         IF ( Lwork>=MAX(4*M+M*Lda+MAX(M,2*M-4,Nrhs,N-3*M),             &
     &        M*Lda+M+M*Nrhs) ) ldwork = Lda
         itau = 1
         iwork = M + 1
!
!        Compute A=L*Q
!        (Workspace: need 2*M, prefer M+M*NB)
!
         CALL SGELQF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1,    &
     &               Info)
         il = iwork
!
!        Copy L to WORK(IL), zeroing out above it
!
         CALL SLACPY('L',M,M,A,Lda,Work(il),ldwork)
         CALL SLASET('U',M-1,M-1,ZERO,ZERO,Work(il+ldwork),ldwork)
         ie = il + ldwork*M
         itauq = ie + M
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize L in WORK(IL)
!        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
!
         CALL SGEBRD(M,M,Work(il),ldwork,S,Work(ie),Work(itauq),        &
     &               Work(itaup),Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of L
!        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
!
         CALL SORMBR('Q','L','T',M,Nrhs,M,Work(il),ldwork,Work(itauq),B,&
     &               Ldb,Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in WORK(IL)
!        (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
!
         CALL SORGBR('P',M,M,M,Work(il),ldwork,Work(itaup),Work(iwork), &
     &               Lwork-iwork+1,Info)
         iwork = ie + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of L in WORK(IL) and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need M*M+M+BDSPAC)
!
         CALL SBDSQR('U',M,M,0,Nrhs,S,Work(ie),Work(il),ldwork,A,Lda,B, &
     &               Ldb,Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
         iwork = ie
!
!        Multiply B by right singular vectors of L in WORK(IL)
!        (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs+iwork-1 .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',M,Nrhs,M,ONE,Work(il),ldwork,B,Ldb,ZERO, &
     &                 Work(iwork),Ldb)
            CALL SLACPY('G',M,Nrhs,Work(iwork),Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = (Lwork-iwork+1)/M
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',M,bl,M,ONE,Work(il),ldwork,B(1,i),Ldb,&
     &                    ZERO,Work(iwork),M)
               CALL SLACPY('G',M,bl,Work(iwork),M,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',M,M,ONE,Work(il),ldwork,B(1,1),1,ZERO,       &
     &                 Work(iwork),1)
            CALL SCOPY(M,Work(iwork),1,B(1,1),1)
         ENDIF
!
!        Zero out below first M rows of B
!
         CALL SLASET('F',N-M,Nrhs,ZERO,ZERO,B(M+1,1),Ldb)
         iwork = itau + M
!
!        Multiply transpose(Q) by B
!        (Workspace: need M+NRHS, prefer M+NRHS*NB)
!
         CALL SORMLQ('L','T',N,Nrhs,M,A,Lda,Work(itau),B,Ldb,Work(iwork)&
     &               ,Lwork-iwork+1,Info)
!
      ELSE
!
!        Path 2 - remaining underdetermined cases
!
         ie = 1
         itauq = ie + M
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize A
!        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
!
         CALL SGEBRD(M,N,A,Lda,S,Work(ie),Work(itauq),Work(itaup),      &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors
!        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
!
         CALL SORMBR('Q','L','T',M,Nrhs,N,A,Lda,Work(itauq),B,Ldb,      &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors in A
!        (Workspace: need 4*M, prefer 3*M+M*NB)
!
         CALL SORGBR('P',M,N,M,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         iwork = ie + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of A in A and
!           multiplying B by transpose of left singular vectors
!        (Workspace: need BDSPAC)
!
         CALL SBDSQR('L',M,N,0,Nrhs,S,Work(ie),A,Lda,dum,1,B,Ldb,       &
     &               Work(iwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL SRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL SLASET('F',1,Nrhs,ZERO,ZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors of A
!        (Workspace: need N, prefer N*NRHS)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL SGEMM('T','N',N,Nrhs,M,ONE,A,Lda,B,Ldb,ZERO,Work,Ldb)
            CALL SLACPY('F',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL SGEMM('T','N',N,bl,M,ONE,A,Lda,B(1,i),Ldb,ZERO,Work,&
     &                    N)
               CALL SLACPY('F',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL SGEMV('T',M,N,ONE,A,Lda,B,1,ZERO,Work,1)
            CALL SCOPY(N,Work,1,B,1)
         ENDIF
      ENDIF
!
!     Undo scaling
!
      IF ( iascl==1 ) THEN
         CALL SLASCL('G',0,0,anrm,smlnum,N,Nrhs,B,Ldb,Info)
         CALL SLASCL('G',0,0,smlnum,anrm,minmn,1,S,minmn,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL SLASCL('G',0,0,anrm,bignum,N,Nrhs,B,Ldb,Info)
         CALL SLASCL('G',0,0,bignum,anrm,minmn,1,S,minmn,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL SLASCL('G',0,0,smlnum,bnrm,N,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL SLASCL('G',0,0,bignum,bnrm,N,Nrhs,B,Ldb,Info)
      ENDIF
!
 100  Work(1) = maxwrk
!
!     End of SGELSS
!
      END SUBROUTINE SGELSS


text:
module assert_equals_within_absolute_array_test
    use iso_varying_string, only: var_str
    use vegetables, only: &
        result_t, &
        test_item_t, &
        assert_equals_within_absolute, &
        assert_not, &
        assert_that, &
        describe, &
        it

    implicit none
    private
    public :: test_assert_eq_within_abs_arr

    character(len=*), parameter :: BOTH_MESSAGE = "Both Message"
    character(len=*), parameter :: SUCCESS_MESSAGE = "Success Message"
    character(len=*), parameter :: FAILURE_MESSAGE = "Failure Message"
contains
    function test_assert_eq_within_abs_arr() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "assert_equals_within_absolute for arrays", &
                [ it( &
                        "passes with the same array, even with very small tolerance", &
                        check_pass_for_same_array) &
                , it( &
                        "fails for arrays with sufficiently different values", &
                        check_fail_for_different_arrays) &
                , it( &
                        "passes for arrays with sufficiently close values", &
                        check_pass_for_close_arrays) &
                , it( &
                        "fails for arrays of different lengths", &
                        check_fail_for_different_length_arrays) &
                ])
    end function

    pure function check_pass_for_same_array() result(result_)
        type(result_t) :: result_

        type(result_t) :: example_result
        type(result_t) :: example_result_c
        type(result_t) :: example_result_s
        type(result_t) :: example_result_cc
        type(result_t) :: example_result_cs
        type(result_t) :: example_result_sc
        type(result_t) :: example_result_ss

        associate(example => [1.0d0, 2.0d0])
            example_result = assert_equals_within_absolute( &
                    example, example, tiny(0.0d0))
            example_result_c = assert_equals_within_absolute( &
                    example, example, tiny(0.0d0), BOTH_MESSAGE)
            example_result_s = assert_equals_within_absolute( &
                    example, example, tiny(0.0d0), var_str(BOTH_MESSAGE))
            example_result_cc = assert_equals_within_absolute( &
                    example, &
                    example, &
                    tiny(0.0d0), &
                    SUCCESS_MESSAGE, &
                    FAILURE_MESSAGE)
            example_result_cs = assert_equals_within_absolute( &
                    example, &
                    example, &
                    tiny(0.0d0), &
                    SUCCESS_MESSAGE, &
                    var_str(FAILURE_MESSAGE))
            example_result_sc = assert_equals_within_absolute( &
                    example, &
                    example, &
                    tiny(0.0d0), &
                    var_str(SUCCESS_MESSAGE), &
                    FAILURE_MESSAGE)
            example_result_ss = assert_equals_within_absolute( &
                    example, &
                    example, &
                    tiny(0.0d0), &
                    var_str(SUCCESS_MESSAGE), &
                    var_str(FAILURE_MESSAGE))
        end associate

        result_ = &
                assert_that( &
                        example_result%passed(), &
                        example_result%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_c%passed(), &
                        example_result_c%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_s%passed(), &
                        example_result_s%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_cc%passed(), &
                        example_result_cc%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_cs%passed(), &
                        example_result_cs%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_sc%passed(), &
                        example_result_sc%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_ss%passed(), &
                        example_result_ss%verbose_description(.false.))
    end function

    pure function check_fail_for_different_arrays() result(result_)
        type(result_t) :: result_

        type(result_t) :: example_result
        type(result_t) :: example_result_c
        type(result_t) :: example_result_s
        type(result_t) :: example_result_cc
        type(result_t) :: example_result_cs
        type(result_t) :: example_result_sc
        type(result_t) :: example_result_ss

        associate(example => [1.0d0, 2.0d0])
            example_result = assert_equals_within_absolute( &
                    example, example+0.2d0, 0.1d0)
            example_result_c = assert_equals_within_absolute( &
                    example, example+0.2d0, 0.1d0, BOTH_MESSAGE)
            example_result_s = assert_equals_within_absolute( &
                    example, example+0.2d0, 0.1d0, var_str(BOTH_MESSAGE))
            example_result_cc = assert_equals_within_absolute( &
                    example, &
                    example+0.2d0, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    FAILURE_MESSAGE)
            example_result_cs = assert_equals_within_absolute( &
                    example, &
                    example+0.2d0, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    var_str(FAILURE_MESSAGE))
            example_result_sc = assert_equals_within_absolute( &
                    example, &
                    example+0.2d0, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    FAILURE_MESSAGE)
            example_result_ss = assert_equals_within_absolute( &
                    example, &
                    example+0.2d0, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    var_str(FAILURE_MESSAGE))
        end associate

        result_ = &
                assert_not( &
                        example_result%passed(), &
                        example_result%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_c%passed(), &
                        example_result_c%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_s%passed(), &
                        example_result_s%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_cc%passed(), &
                        example_result_cc%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_cs%passed(), &
                        example_result_cs%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_sc%passed(), &
                        example_result_sc%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_ss%passed(), &
                        example_result_ss%verbose_description(.false.))
    end function

    pure function check_pass_for_close_arrays() result(result_)
        type(result_t) :: result_

        type(result_t) :: example_result
        type(result_t) :: example_result_c
        type(result_t) :: example_result_s
        type(result_t) :: example_result_cc
        type(result_t) :: example_result_cs
        type(result_t) :: example_result_sc
        type(result_t) :: example_result_ss

        associate(example => [1.0d0, 2.0d0])
            example_result = assert_equals_within_absolute( &
                    example, example+0.05d0, 0.1d0)
            example_result_c = assert_equals_within_absolute( &
                    example, example+0.05d0, 0.1d0, BOTH_MESSAGE)
            example_result_s = assert_equals_within_absolute( &
                    example, example+0.05d0, 0.1d0, var_str(BOTH_MESSAGE))
            example_result_cc = assert_equals_within_absolute( &
                    example, &
                    example+0.05d0, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    FAILURE_MESSAGE)
            example_result_cs = assert_equals_within_absolute( &
                    example, &
                    example+0.05d0, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    var_str(FAILURE_MESSAGE))
            example_result_sc = assert_equals_within_absolute( &
                    example, &
                    example+0.05d0, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    FAILURE_MESSAGE)
            example_result_ss = assert_equals_within_absolute( &
                    example, &
                    example+0.05d0, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    var_str(FAILURE_MESSAGE))
        end associate

        result_ = &
                assert_that( &
                        example_result%passed(), &
                        example_result%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_c%passed(), &
                        example_result_c%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_s%passed(), &
                        example_result_s%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_cc%passed(), &
                        example_result_cc%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_cs%passed(), &
                        example_result_cs%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_sc%passed(), &
                        example_result_sc%verbose_description(.false.)) &
                .and.assert_that( &
                        example_result_ss%passed(), &
                        example_result_ss%verbose_description(.false.))
    end function

    pure function check_fail_for_different_length_arrays() result(result_)
        type(result_t) :: result_

        type(result_t) :: example_result
        type(result_t) :: example_result_c
        type(result_t) :: example_result_s
        type(result_t) :: example_result_cc
        type(result_t) :: example_result_cs
        type(result_t) :: example_result_sc
        type(result_t) :: example_result_ss

        associate(example1 => [1.0d0, 2.0d0], example2 => [1.0d0, 2.0d0, 3.0d0])
            example_result = assert_equals_within_absolute( &
                    example1, example2, 0.1d0)
            example_result_c = assert_equals_within_absolute( &
                    example1, example2, 0.1d0, BOTH_MESSAGE)
            example_result_s = assert_equals_within_absolute( &
                    example1, example2, 0.1d0, var_str(BOTH_MESSAGE))
            example_result_cc = assert_equals_within_absolute( &
                    example1, &
                    example2, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    FAILURE_MESSAGE)
            example_result_cs = assert_equals_within_absolute( &
                    example1, &
                    example2, &
                    0.1d0, &
                    SUCCESS_MESSAGE, &
                    var_str(FAILURE_MESSAGE))
            example_result_sc = assert_equals_within_absolute( &
                    example1, &
                    example2, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    FAILURE_MESSAGE)
            example_result_ss = assert_equals_within_absolute( &
                    example1, &
                    example2, &
                    0.1d0, &
                    var_str(SUCCESS_MESSAGE), &
                    var_str(FAILURE_MESSAGE))
        end associate

        result_ = &
                assert_not( &
                        example_result%passed(), &
                        example_result%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_c%passed(), &
                        example_result_c%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_s%passed(), &
                        example_result_s%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_cc%passed(), &
                        example_result_cc%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_cs%passed(), &
                        example_result_cs%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_sc%passed(), &
                        example_result_sc%verbose_description(.false.)) &
                .and.assert_not( &
                        example_result_ss%passed(), &
                        example_result_ss%verbose_description(.false.))
    end function
end module

max_stars_repo_name: everythingfunctional/vegetables

max_issues_repo_name: everythingfunctional/vegetables

max_forks_repo_name: everythingfunctional/vegetables


text:
      subroutine evspline(xget,x,nx,ilinx,f,ict,fval,ier)
C
C  use mkspline to set up spline coefficients...
C
C  evaluate a 1d cubic Spline interpolant -- this is C2
C
C  this subroutine calls two subroutines:
C     herm1x  -- find cell containing (xget)
C     fvspline  -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
      integer nx                        ! grid size
      real xget                         ! target of this interpolation
      real x(nx)                        ! ordered x grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
C
      real f(0:1,nx)                    ! function data
C
C  f(0,i) = f @ x(i)
C  f(1,i) = d2f/dx2 @ x(i)
C
C      (these are spline coefficients selected for continuous 2-
C      diffentiability, see mkspline.for)
C
      integer ict(3)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C  ict(3)=1 -- return d2f/dx2  (0, don't)
c
c        set ict(1)=3 to get d3f/dx3 (only)
C
C output arguments:
C =================
C
      real fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C  fval(3) receives the third output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1,1]
C   on output fval= [f,df/dx,d2f/dx2]
C
C    on input ict = [1,0,0]
C   on output fval= [f] ... elements 2 -- 3 never referenced.
C
C    on input ict = [0,0,1]
C   on output fval= [d2f/dx2] ... elements 2 -- 3 never referenced.
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer i(1)                         ! cell indices
C
C  normalized displacement from x(i) grid point.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C
      real xparam(1)
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i))
C
      real hx(1)
      real hxi(1)
C
C  0 .le. xparam .le. 1
C
C  ** the interface is very similar to herm2ev.for; can use herm2xy **
C---------------------------------------------------------------------
C
      i(1)=0
C
      call herm1x(xget,x,nx,ilinx,i(1),xparam(1),hx(1),hxi(1),ier)
      if(ier.ne.0) return
c
      call fvspline(ict,1,1,fval,i,xparam,hx,hxi,f,nx)
C
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine fvspline(ict,ivec,ivecd,
     >   fval,ii,xparam,hx,hxi,fin,nx)
C
C  use mkspline to set up spline coefficients...
C
      integer ict(3)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec)                  ! target cells (i)
      real xparam(ivec)
                          ! normalized displacements from (i) corners
C
      real hx(ivec)                     ! grid spacing, and
      real hxi(ivec)                    ! inverse grid spacing 1/(x(i+1)-x(i))
C
      real fin(0:1,nx)                  ! interpolant data (cf "evspline")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  evspline comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii and parameter inputs
C     xparam,hx,hxi, are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C  Spline evaluation consists of a "mixing" of the interpolant
C  data using the linear functionals xparam, xpi = 1-xparam,
C  xparam**3-xparam, xpi**3-xpi ...
C  and their derivatives as needed.
C
      integer v
C
      real sum
      real sixth
C
      data sixth/0.166666666666666667/
C
C---------------
C   ...in x direction
C
      iadr=0
C
      if(ict(1).le.2) then
C
C  normal call
C
         if(ict(1).eq.1) then
C
C  get desired values:
C
            iadr = iadr + 1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0)
               cxi=xpi*(xpi2-1.0)
               hx2=hx(v)*hx(v)
C
C  function value:
C
               sum=xpi*fin(0,i) +xp*fin(0,i+1)
               sum=sum+sixth*hx2*(cxi*fin(1,i) +cx*fin(1,i+1))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cxd=3.0*xp2-1.0
               cxdi=-3.0*xpi2+1.0

               sum=hxi(v)*(fin(0,i+1)-fin(0,i))
               sum=sum+sixth*hx(v)*(cxdi*fin(1,i) +cxd*fin(1,i+1))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(3).eq.1) then
C
C  d2f/dx2:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
C
               sum=xpi*fin(1,i) +xp*fin(1,i+1)
               fval(v,iadr)=sum
            enddo
         endif
C
      else
C
C  return fxxx = d3f/dx3
C
         iadr=1
         do v=1,ivec
            i=ii(v)
            fval(v,iadr)=hxi(v)*(fin(1,i+1)-fin(1,i))
         enddo
C
      endif
C
      return
      end

ext: f

max_stars_repo_name: ORNL-Fusion/RFSciDAC-testing

max_issues_repo_name: ORNL-Fusion/RFSciDAC-testing

max_forks_repo_name: ORNL-Fusion/RFSciDAC-testing


text: 20070620 18:09:28 nbsp The CVC allows you the full use of a traffic lane if the bike lane is unsuitable for use, due to debris as such. If youre riding late at night and your light isnt good enough to see the debris in the bike lane, move on left. Users/WilliamLewis

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
*> \brief \b ZLAROT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
*                          XRIGHT )
*
*       .. Scalar Arguments ..
*       LOGICAL            LLEFT, LRIGHT, LROWS
*       INTEGER            LDA, NL
*       COMPLEX*16         C, S, XLEFT, XRIGHT
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         A( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    ZLAROT applies a (Givens) rotation to two adjacent rows or
*>    columns, where one element of the first and/or last column/row
*>    for use on matrices stored in some format other than GE, so
*>    that elements of the matrix may be used or modified for which
*>    no array element is provided.
*>
*>    One example is a symmetric matrix in SB format (bandwidth=4), for
*>    which UPLO='L':  Two adjacent rows will have the format:
*>
*>    row j:     C> C> C> C> C> .  .  .  .
*>    row j+1:      C> C> C> C> C> .  .  .  .
*>
*>    '*' indicates elements for which storage is provided,
*>    '.' indicates elements for which no storage is provided, but
*>    are not necessarily zero; their values are determined by
*>    symmetry.  ' ' indicates elements which are necessarily zero,
*>     and have no storage provided.
*>
*>    Those columns which have two '*'s can be handled by DROT.
*>    Those columns which have no '*'s can be ignored, since as long
*>    as the Givens rotations are carefully applied to preserve
*>    symmetry, their values are determined.
*>    Those columns which have one '*' have to be handled separately,
*>    by using separate variables "p" and "q":
*>
*>    row j:     C> C> C> C> C> p  .  .  .
*>    row j+1:   q  C> C> C> C> C> .  .  .  .
*>
*>    The element p would have to be set correctly, then that column
*>    is rotated, setting p to its new value.  The next call to
*>    ZLAROT would rotate columns j and j+1, using p, and restore
*>    symmetry.  The element q would start out being zero, and be
*>    made non-zero by the rotation.  Later, rotations would presumably
*>    be chosen to zero q out.
*>
*>    Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
*>    ------- ------- ---------
*>
*>      General dense matrix:
*>
*>              CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
*>                      A(i,1),LDA, DUMMY, DUMMY)
*>
*>      General banded matrix in GB format:
*>
*>              j = MAX(1, i-KL )
*>              NL = MIN( N, i+KU+1 ) + 1-j
*>              CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
*>                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
*>
*>              [ note that i+1-j is just MIN(i,KL+1) ]
*>
*>      Symmetric banded matrix in SY format, bandwidth K,
*>      lower triangle only:
*>
*>              j = MAX(1, i-K )
*>              NL = MIN( K+1, i ) + 1
*>              CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
*>                      A(i,j), LDA, XLEFT, XRIGHT )
*>
*>      Same, but upper triangle only:
*>
*>              NL = MIN( K+1, N-i ) + 1
*>              CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
*>                      A(i,i), LDA, XLEFT, XRIGHT )
*>
*>      Symmetric banded matrix in SB format, bandwidth K,
*>      lower triangle only:
*>
*>              [ same as for SY, except:]
*>                  . . . .
*>                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
*>
*>              [ note that i+1-j is just MIN(i,K+1) ]
*>
*>      Same, but upper triangle only:
*>                  . . .
*>                      A(K+1,i), LDA-1, XLEFT, XRIGHT )
*>
*>      Rotating columns is just the transpose of rotating rows, except
*>      for GB and SB: (rotating columns i and i+1)
*>
*>      GB:
*>              j = MAX(1, i-KU )
*>              NL = MIN( N, i+KL+1 ) + 1-j
*>              CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
*>                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
*>
*>              [note that KU+j+1-i is just MAX(1,KU+2-i)]
*>
*>      SB: (upper triangle)
*>
*>                   . . . . . .
*>                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
*>
*>      SB: (lower triangle)
*>
*>                   . . . . . .
*>                      A(1,i),LDA-1, XTOP, XBOTTM )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \verbatim
*>  LROWS  - LOGICAL
*>           If .TRUE., then ZLAROT will rotate two rows.  If .FALSE.,
*>           then it will rotate two columns.
*>           Not modified.
*>
*>  LLEFT  - LOGICAL
*>           If .TRUE., then XLEFT will be used instead of the
*>           corresponding element of A for the first element in the
*>           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
*>           If .FALSE., then the corresponding element of A will be
*>           used.
*>           Not modified.
*>
*>  LRIGHT - LOGICAL
*>           If .TRUE., then XRIGHT will be used instead of the
*>           corresponding element of A for the last element in the
*>           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
*>           .FALSE., then the corresponding element of A will be used.
*>           Not modified.
*>
*>  NL     - INTEGER
*>           The length of the rows (if LROWS=.TRUE.) or columns (if
*>           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are
*>           used, the columns/rows they are in should be included in
*>           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
*>           least 2.  The number of rows/columns to be rotated
*>           exclusive of those involving XLEFT and/or XRIGHT may
*>           not be negative, i.e., NL minus how many of LLEFT and
*>           LRIGHT are .TRUE. must be at least zero; if not, XERBLA
*>           will be called.
*>           Not modified.
*>
*>  C, S   - COMPLEX*16
*>           Specify the Givens rotation to be applied.  If LROWS is
*>           true, then the matrix ( c  s )
*>                                 ( _  _ )
*>                                 (-s  c )  is applied from the left;
*>           if false, then the transpose (not conjugated) thereof is
*>           applied from the right.  Note that in contrast to the
*>           output of ZROTG or to most versions of ZROT, both C and S
*>           are complex.  For a Givens rotation, |C|**2 + |S|**2 should
*>           be 1, but this is not checked.
*>           Not modified.
*>
*>  A      - COMPLEX*16 array.
*>           The array containing the rows/columns to be rotated.  The
*>           first element of A should be the upper left element to
*>           be rotated.
*>           Read and modified.
*>
*>  LDA    - INTEGER
*>           The "effective" leading dimension of A.  If A contains
*>           a matrix stored in GE, HE, or SY format, then this is just
*>           the leading dimension of A as dimensioned in the calling
*>           routine.  If A contains a matrix stored in band (GB, HB, or
*>           SB) format, then this should be *one less* than the leading
*>           dimension used in the calling routine.  Thus, if A were
*>           dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the
*>           j-th element in the first of the two rows to be rotated,
*>           and A(2,j) would be the j-th in the second, regardless of
*>           how the array may be stored in the calling routine.  [A
*>           cannot, however, actually be dimensioned thus, since for
*>           band format, the row number may exceed LDA, which is not
*>           legal FORTRAN.]
*>           If LROWS=.TRUE., then LDA must be at least 1, otherwise
*>           it must be at least NL minus the number of .TRUE. values
*>           in XLEFT and XRIGHT.
*>           Not modified.
*>
*>  XLEFT  - COMPLEX*16
*>           If LLEFT is .TRUE., then XLEFT will be used and modified
*>           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
*>           (if LROWS=.FALSE.).
*>           Read and modified.
*>
*>  XRIGHT - COMPLEX*16
*>           If LRIGHT is .TRUE., then XRIGHT will be used and modified
*>           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
*>           (if LROWS=.FALSE.).
*>           Read and modified.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_matgen
*
*  =====================================================================
      SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT,
     $                   XRIGHT )
*
*  -- LAPACK auxiliary routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      LOGICAL            LLEFT, LRIGHT, LROWS
      INTEGER            LDA, NL
      COMPLEX*16         C, S, XLEFT, XRIGHT
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            IINC, INEXT, IX, IY, IYT, J, NT
      COMPLEX*16         TEMPX
*     ..
*     .. Local Arrays ..
      COMPLEX*16         XT( 2 ), YT( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCONJG
*     ..
*     .. Executable Statements ..
*
*     Set up indices, arrays for ends
*
      IF( LROWS ) THEN
         IINC = LDA
         INEXT = 1
      ELSE
         IINC = 1
         INEXT = LDA
      END IF
*
      IF( LLEFT ) THEN
         NT = 1
         IX = 1 + IINC
         IY = 2 + LDA
         XT( 1 ) = A( 1 )
         YT( 1 ) = XLEFT
      ELSE
         NT = 0
         IX = 1
         IY = 1 + INEXT
      END IF
*
      IF( LRIGHT ) THEN
         IYT = 1 + INEXT + ( NL-1 )*IINC
         NT = NT + 1
         XT( NT ) = XRIGHT
         YT( NT ) = A( IYT )
      END IF
*
*     Check for errors
*
      IF( NL.LT.NT ) THEN
         CALL XERBLA( 'ZLAROT', 4 )
         RETURN
      END IF
      IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN
         CALL XERBLA( 'ZLAROT', 8 )
         RETURN
      END IF
*
*     Rotate
*
*     ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S
*
      DO 10 J = 0, NL - NT - 1
         TEMPX = C*A( IX+J*IINC ) + S*A( IY+J*IINC )
         A( IY+J*IINC ) = -DCONJG( S )*A( IX+J*IINC ) +
     $                    DCONJG( C )*A( IY+J*IINC )
         A( IX+J*IINC ) = TEMPX
   10 CONTINUE
*
*     ZROT( NT, XT,1, YT,1, C, S ) with complex C, S
*
      DO 20 J = 1, NT
         TEMPX = C*XT( J ) + S*YT( J )
         YT( J ) = -DCONJG( S )*XT( J ) + DCONJG( C )*YT( J )
         XT( J ) = TEMPX
   20 CONTINUE
*
*     Stuff values back into XLEFT, XRIGHT, etc.
*
      IF( LLEFT ) THEN
         A( 1 ) = XT( 1 )
         XLEFT = YT( 1 )
      END IF
*
      IF( LRIGHT ) THEN
         XRIGHT = XT( NT )
         A( IYT ) = YT( NT )
      END IF
*
      RETURN
*
*     End of ZLAROT
*
      END

max_stars_repo_name: haampie/libflame

max_issues_repo_name: haampie/libflame

max_forks_repo_name: haampie/libflame