	SUBROUTINE GCONML ( mproj, msppj, np, dlat, dlon, a1, reflon,
     +			    a3, concon, xl, yl, iret)
C************************************************************************
C* GCONML								*
C* 									*
C* This subroutine transforms a point from latitude-longitude		*
C* coordinates to linear intermediate coordinates for conical		*
C* projections. This is conic with two standard	parallels.		*
C* 									*
C* GCONML  ( MPROJ, MSPPJ, NP, DLAT, DLON, A1, REFLON, A3, CONCON,	*
C*           XL,    YL,    IRET )					*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Map class			*
C*	MSPPJ		INTEGER		Map projection			*
C*	NP		INTEGER		Number of points		*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C*	A1		REAL		Not used			*
C*	REFLON		REAL		Central longitude		*
C*	A3		REAL		Not used			*
C*	CONCON		REAL		Cone constant			*
C* 									*
C* Output parameters:							*
C*	XL (NP)		REAL		X linear coordinates		*
C*	YL (NP)		REAL		Y linear coordinates		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 1/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 1/88	Fixed missing data			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* K. Brill/EMC		 3/96	Changes for general rotation		*
C* K. Brill/EMC		 5/96	Check for latitude out of range		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL    	xl (*), yl (*), dlat (*), dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C-------------------------------------------------------------------------
	iret = NORMAL
C
C*	Loop through all points.
C
	plon = reflon * RTD
	DO i = 1, np
	    IF ( .not. ERMISS ( dlon (i) ) ) THEN
		yl (i) = dlon (i) - plon
	    ELSE
		yl (i) = RMISSD
	    END IF
	END DO
	CALL PRNLON ( np, yl, ier )
C*
	DO  i = 1, np
C
C*	  Check for missing data.
C
	  IF  ( ( .not. ERMISS ( dlat (i) ) ) .and.
     +		( .not. ERMISS ( yl (i) ) ) .and. .not.
     +          ( dlat (i) .gt. 90.0 .or. dlat (i) .lt. -90.0 )
     +        )  THEN
	    rlat   = dlat (i) * DTR
	    rlon   = yl (i) * DTR
	    xl (i) = RMISSD
	    yl (i) = RMISSD
C
C*	   Computation depends on pole of projection.
C
	   IF ( mproj .eq. MPCNOR ) THEN
		ang1 = PI4TH - 0.5 * rlat
C
		IF ( ang1 .lt. HALFPI ) THEN
		    r       = TAN ( ang1 ) ** concon
		    ang2    = concon * ( rlon )
		    xl (i)  =  r * SIN ( ang2 )
		    yl (i)  = (-r) * COS ( ang2 )
		END IF
C*
	      ELSE IF ( mproj .eq. MPCSOU ) THEN
		ang1 = PI4TH + 0.5 * rlat
C
		IF ( ang1 .lT. HALFPI ) THEN
		    r    = TAN ( ang1 ) ** concon
		    ang2 = concon * ( rlon )
		    xl (i)  = r * SIN ( ang2 )
		    yl (i)  = r * COS ( ang2 )
		END IF
	    END IF
	  ELSE
	    xl (i) = RMISSD
	    yl (i) = RMISSD
	  END IF
	END DO
C*
	RETURN
	END


C$Procedure      ZZASRYEL ( Angular separation of ray and ellipse )

      SUBROUTINE ZZASRYEL ( EXTREM, ELLIPS, VERTEX, DIR, ANGLE, EXTPT )
      IMPLICIT NONE

C$ Abstract
C
C     Find the minimum or maximum angular separation between a
C     specified ray and ellipse.
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     ELLIPSES
C
C$ Keywords
C
C     ELLIPSE
C     ELLIPSOID
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL   = 9 )

      INTEGER               UBPL
      PARAMETER           ( UBPL   = 4 )

      CHARACTER*(*)         EXTREM
      DOUBLE PRECISION      ELLIPS ( UBEL )
      DOUBLE PRECISION      VERTEX ( 3 )
      DOUBLE PRECISION      DIR    ( 3 )
      DOUBLE PRECISION      ANGLE
      DOUBLE PRECISION      EXTPT  ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     UBEL       P   Upper bound of SPICELIB ellipse.
C     UBPL       P   Upper bound of SPICELIB plane.
C     EXTREM     I   Type of extremum to find.
C     ELLIPS     I   SPICE ellipse.
C     VERTEX,
C     DIR        I   Vertex and direction vector of ray.
C     ANGLE      O   Angular separation of ray and ellipse (radians).
C     EXTPT      O   Point on ellipse where extremum is achieved.
C
C$ Detailed_Input
C
C     EXTREM         is a string indicating the type of extremum to
C                    find.  Values are 'MIN' and 'MAX'.  Blanks and
C                    case are not significant.  Only the first three
C                    non-blank characters of EXTREM are significant.
C
C
C     ELLIPS         is a SPICELIB ellipse data structure. ELLIPS must
C                    have non-zero semi-axis lengths.
C
C
C     VERTEX,
C     DIR            are the vertex and direction vector of a ray in
C                    three-dimensional space.
C
C$ Detailed_Output
C
C     ANGLE          is the specified extremum of angular separation of
C                    the input ray and the ellipse.  This is the
C                    minimum or maximum angular separation of the ray
C                    and any line segment extending from the ray's
C                    vertex to a point on the surface of the ellipse.
C                    Units are radians.
C
C                    If the input ray actually intersects the plane
C                    region bounded by the ellipse, ANGLE is set to a
C                    non-positive value whose magnitude is the minimum
C                    or maximum angular separation of the input ray and
C                    the ellipse.
C
C
C     EXTPT          is the point on the ellipse where the specified
C                    extreme value of the angular separation is
C                    achieved.  If there are multiple points where the
C                    extremum is achieved, any such point may be
C                    selected.
C
C$ Parameters
C
C     UBEL           is the upper bound of a SPICELIB ellipse data
C                    structure.
C
C     UBPL           is the upper bound of a SPICELIB plane data
C                    structure.
C
C$ Exceptions
C
C     1)  If the length of any semi-axis of the ellipse is
C         non-positive, the error SPICE(INVALIDAXISLENGTH) is
C         signaled.  ANGLE and EXTPT are not modified.
C
C     2)  If VERTEX lies in the plane of the ellipse, the error
C         SPICE(DEGENERATECASE) is signaled.  ANGLE and EXTPT are not
C         modified.
C
C     3)  If DIR is the zero vector, the error SPICE(ZEROVECTOR) is
C         signaled.  ANGLE and EXTPT are not modified.
C
C     4)  If EXTREM contains an unrecognized value, the error
C         SPICE(NOTSUPPORTED) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Definition
C     ==========
C
C     The minimum or maximum angular separation of a ray and ellipse is
C     the minimum or maximum, taken over all points on the ellipse, of
C     the angular separation of the ray and the vector from the ray's
C     vertex to a point on the ellipse.
C
C     Uniqueness or multiplicity of minima
C     ====================================
C
C     Let's presume that the ray does not intersect the plane region
C     bounded by the ellipse.  If the ray's vertex does not lie in the
C     plane of the ellipse, the uniqueness of the minimizing point can
C     be verified by observing that the right circular cone of minimum
C     angular extent whose axis is the ray, and that is tangent to the
C     ellipse, will be tangent at the minimizing point and no other.
C     If the ray's vertex does lie in the plane of the ellipse, there
C     can be multiple tangency points.
C
C     If the ray intersects the plane region bounded by the ellipse,
C     there may be multiple absolute minima of the angular separation.
C     Consider the case where the ellipse is a circular cross section
C     of a right circular cone, and the ray is the cone's axis:  there
C     is an infinite set of solutions, since the minimum angular
C     separation is achieved at every point on the circle.
C
C
C     Uniqueness or multiplicity of maxima
C     ====================================
C
C     Let's presume that the ray does not intersect the plane region
C     bounded by the ellipse.  If the ray's vertex does not lie in the
C     plane of the ellipse, one observes that the right circular cone
C     of maximum angular extent whose axis is the ray, and that is
C     tangent to the ellipse, can still easily be tangent to the
C     ellipse at multiple points (consider an ellipse whose shape is
C     "almost" a line segment). The ray's vertex need not lie in the
C     plane of the ellipse for multiple tangency points to exist.
C
C     If the ray intersects the plane region bounded by the ellipse,
C     there may be multiple absolute maxima of the angular separation.
C
C
C     Extremum of angular separation versus distance
C     ==============================================
C
C     Note the point on the ellipse having minimum angular separation
C     from a ray is NOT necessarily the closest point on the ellipse to
C     the ray. You can verify this by considering the case of an
C     extremely eccentric ellipse and a ray that passes above it.   The
C     diagram below illustrates this situation.  The series of three
C     asterisks rising from left to right represents the ray; the other
C     asterisks represent the ellipse. The point `c' is the closest
C     point on the ellipse to the ray; the point `m' has the minimum
C     angular separation from the ray.
C
C     The analoguous distinction applies to maximum angular separation
C     and maximum distance:  compare the points labeled 'M' and 'F'
C     in the diagram below.
C
C
C
C                                                            *
C                                                          (ray)
C                                  *
C    ray's vertex                (ray)
C        *
C
C
C  closest ellipse  ---->   c * * * * * * * * m   <-- point of minimum
C  point to the ray       *                     *        angular
C                           M * * * * * * * * F          separation
C
C                           ^                 ^
C     point of maximum angular                farthest ellipse
C     separation                              point from ray
C
C
C
C
C     Applications
C     ============
C
C     This subroutine can be used to:
C
C        -  measure the angular separation of
C           an instrument boresight from a body's limb
C
C        -  test for visibility of an ellipsoidal body within an
C           circular field of view (or, with more work, an elliptical
C           field of view)
C
C        -  test for occultation of one ellipsoidal body by another
C
C        -  support tests for intersection of an ellipsoidal body with
C           an umbral or penumbral shadow cast by another ellipsoidal
C           body blocking an ellipsoidal light source.
C
C$ Examples
C
C     1)  An example that can be readily checked by hand computation.
C
C            Let
C
C               A = 1
C               B = 1
C               C = 1
C
C               V = ( 2,   0,  0       )
C               D = ( -1,  0,  SQRT(3) )
C
C            The limb of the sphere as seen from the ray's vertex will
C            be the circle centered at ( .5, 0, 0 ), parallel to the
C            y-z plane,  with radius SQRT(3)/2.  The ray lies in the
C            x-z plane and passes over the ellipse, so the limb point
C            of minimum angular separation should be the highest point
C            on the limb.  This would be the point
C
C               ( .5, 0, SQRT(3)/2 ).
C
C            The tangent segment extending from the ray's vertex to the
C            point of mimimum angular separation makes an angle of
C            30 degrees with the x-axis, and the ray makes angle of 60
C            degrees with the x-axis, so the angular separation of the
C            ray and the limb should be 30 degrees.
C
C            For a ray have the same vertex but pointing in the -x
C            direction, the minimum point can be anywhere on the limb,
C            but the angle should be -30 degrees.
C
C            If the vertex is raised slightly (that is, the z-component
C            is increased slightly) and the ray points in the -x
C            direction, the mimimum point should be at the top of the
C            limb, and the angle should be a negative value with
C            magnitude slightly less than 30 degrees.
C
C            The program below should verify these results.
C
C
C               PROGRAM MINANG
C               IMPLICIT NONE
C
C               INTEGER               UBEL
C               PARAMETER           ( UBEL   = 9 )
C
C               DOUBLE PRECISION      DPR
C
C               DOUBLE PRECISION      V(3)
C               DOUBLE PRECISION      D(3)
C               DOUBLE PRECISION      A
C               DOUBLE PRECISION      B
C               DOUBLE PRECISION      C
C               DOUBLE PRECISION      ANGLE
C               DOUBLE PRECISION      LIMB  ( UBEL )
C               DOUBLE PRECISION      EXTPT ( 3 )
C
C               V(1) =  2.D0
C               V(2) =  0.D0
C               V(3) =  0.D0
C
C               D(1) = -1.D0
C               D(2) =  0.D0
C               D(3) =  SQRT( 3.D0 )
C
C               A    =  1.D0
C               B    =  1.D0
C               C    =  1.D0
C
C               CALL EDLIMB   ( A, B, C, V, LIMB )
C
C               CALL ZZASRYEL ( 'MIN', LIMB, V, D, ANGLE, EXTPT )
C
C               PRINT *, ' '
C               PRINT *, 'Angle is'
C               PRINT *, DPR() * ANGLE
C               PRINT *, 'Point of mimimum separation is'
C               PRINT *, EXTPT
C
C         C
C         C     Now take the ray along the x-axis,
C         C     pointing in the -x direction.
C         C
C               D(1) = -1.D0
C               D(2) =  0.D0
C               D(3) =  0.D0
C
C               CALL ZZASRYEL ( 'MIN', LIMB, V, D, ANGLE, EXTPT )
C
C               PRINT *, ' '
C               PRINT *, 'Angle is'
C               PRINT *, DPR() * ANGLE
C               PRINT *, 'Point of mimimum separation is'
C               PRINT *, EXTPT
C
C         C
C         C     Raise the vertex a bit and repeat.
C         C
C               V(1) =  2.D0
C               V(2) =  0.D0
C               V(3) =  1.D-6
C
C               CALL ZZASRYEL ( 'MIN', LIMB, V, D, ANGLE, EXTPT )
C
C               PRINT *, ' '
C               PRINT *, 'Angle is'
C               PRINT *, DPR() * ANGLE
C               PRINT *, 'Point of mimimum separation is'
C               PRINT *, EXTPT
C
C               END
C
C
C$ Restrictions
C
C     1) Under some unusual geometric conditions, the search used
C        in this algorithm may find a relative extremum which is not
C        an absolute extremum.  This can occur if there are two local
C        extrema of separation (both minima or both maxima)
C        located less than (2*pi/20) apart in the parameter domain for
C        the ellipse's limb, where the limb is parameterized as
C
C           CENTER + cos(theta)*SMAJOR  + sin(theta)*SMINOR,
C
C           0 <= theta <= 2*pi
C
C        and
C
C           CENTER is the center of the limb
C           SMAJOR is a semi-major axis vector of the limb
C           SMINOR is a semi-minor axis vector of the limb
C
C        The search can also fail to find an absolute extremum in cases
C        where there are two extrema (both minima or both maxima) that
C        are distant but very close to equal in terms of angular
C        separation from the input ray.
C
C
C     2) The point at which the minimum or maximum angular separation
C        occurs is determined to single precision.  Specifically, the
C        angular parameter THETA defining the location relative to the
C        semi-axes is determined at the single precision level.
C
C
C$ Literature_References
C
C     [1]  "Numerical Recipes -- The Art of Scientific Computing" by
C           William H. Press, Brian P. Flannery, Saul A. Teukolsky,
C           Willam T. Vetterling.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     B.V. Semenov    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 28-FEB-2008 (BVS)
C
C        Corrected the contents of the Required_Reading section.
C
C-    SPICELIB Version 1.1.0, 14-NOV-2006 (NJB)
C
C        The parameter NPT has been replaced by two different
C        parameters:  one for the exterior minimum case and one for the
C        complementary cases. This change was made to improve accuracy.
C
C-    SPICELIB Version 1.0.0, 07-SEP-2005 (NJB)
C
C-&

C$ Index_Entries
C
C     angular separation of ray and ellipse
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TOUCHD
      DOUBLE PRECISION      TWOPI
      DOUBLE PRECISION      VDIST
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      VSEP

      LOGICAL               FAILED
      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local parameters
C

C
C     Tolerance used for loop convergence.  This tolerance applies
C     to the angular parameter used to specify points on the ellipse.
C
      DOUBLE PRECISION      TOL
      PARAMETER           ( TOL   = 1.D-9 )

C
C     Number of steps used to search the ellipse for region containing
C     the point of extreme angular separation.  We use two different
C     values:  one for the outer minimum case, which is mathematically
C     well behaved, and one for the other cases.
C
      INTEGER               SMLNPT
      PARAMETER           ( SMLNPT =  320 )

      INTEGER               BIGNPT
      PARAMETER           ( BIGNPT =  400 )

C
C     Maximum number of loop iterations allowed for extremum search.
C
      INTEGER               MAXITR
      PARAMETER           ( MAXITR = 100 )

C
C     Code returned in INRYPL indicating ray lies in plane.
C
      INTEGER               INF
      PARAMETER           ( INF    = -1 )

C
C     String length for extremum specifier.
C
      INTEGER               EXTLEN
      PARAMETER           ( EXTLEN = 3 )

C
C     Local variables
C
      CHARACTER*(EXTLEN)    EXTTYP

      DOUBLE PRECISION      A
      DOUBLE PRECISION      ACOMP
      DOUBLE PRECISION      ASIGN
      DOUBLE PRECISION      B
      DOUBLE PRECISION      BCOMP
      DOUBLE PRECISION      BTWEEN
      DOUBLE PRECISION      BTWPRX
      DOUBLE PRECISION      CENTER ( 3 )
      DOUBLE PRECISION      DELTA
      DOUBLE PRECISION      DIFF   ( 3 )
      DOUBLE PRECISION      EPLANE ( UBPL )
      DOUBLE PRECISION      EXTPRX
      DOUBLE PRECISION      GR
      DOUBLE PRECISION      LEVEL
      DOUBLE PRECISION      LOWER
      DOUBLE PRECISION      LPT    ( 3 )
      DOUBLE PRECISION      NEWPT
      DOUBLE PRECISION      P2
      DOUBLE PRECISION      PROXY
      DOUBLE PRECISION      SMAJOR ( 3 )
      DOUBLE PRECISION      SMINOR ( 3 )
      DOUBLE PRECISION      THETA
      DOUBLE PRECISION      UDIFF  ( 3 )
      DOUBLE PRECISION      UDIR   ( 3 )
      DOUBLE PRECISION      UPPER
      DOUBLE PRECISION      V2     ( 3 )
      DOUBLE PRECISION      VPRJ   ( 3 )
      DOUBLE PRECISION      XOFF   ( 3 )
      DOUBLE PRECISION      XPT    ( 3 )

      INTEGER               I
      INTEGER               EXTIDX
      INTEGER               NITR
      INTEGER               NPT
      INTEGER               NXPTS

      LOGICAL               DOMIN

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

C
C     Decide whether we're looking for a minimum or maximum.
C
      CALL CMPRSS ( ' ', 0, EXTREM, EXTTYP )
      CALL LJUST  (         EXTTYP, EXTTYP )

      IF ( EXTTYP .EQ. 'MIN' ) THEN

         DOMIN = .TRUE.

      ELSE IF ( EXTTYP .EQ. 'MAX' ) THEN

         DOMIN = .FALSE.

      ELSE

         CALL SETMSG ( 'Extremum specifier # was not recognized.' )
         CALL ERRCH  ( '#',  EXTREM                               )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'                      )
         CALL CHKOUT ( 'ZZASRYEL'                                 )
         RETURN

      END IF

C
C     Get the center and semi-axes of the ellipse.
C
      CALL EL2CGV ( ELLIPS, CENTER, SMAJOR, SMINOR )

C
C     The ellipse semi-axes must have positive length.
C
      A   =   VNORM(SMAJOR)
      B   =   VNORM(SMINOR)

      IF (  VZERO(SMAJOR) .OR. VZERO(SMINOR)  )   THEN

         CALL SETMSG ( 'Semi-axis lengths:  A = #, B = #.' )
         CALL ERRDP  ( '#', A                              )
         CALL ERRDP  ( '#', B                              )
         CALL SIGERR ( 'SPICE(INVALIDAXISLENGTH)'          )
         CALL CHKOUT ( 'ZZASRYEL'                          )
         RETURN

      END IF

C
C     Find the plane of the ellipse.
C
      CALL PSV2PL ( CENTER, SMAJOR, SMINOR, EPLANE )

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

C
C     The ray's direction vector must be non-zero.
C
      IF ( VZERO(DIR) ) THEN

         CALL SETMSG ( 'Ray''s direction vector must be non-zero.' )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                         )
         CALL CHKOUT ( 'ZZASRYEL'                                  )
         RETURN

      END IF

C
C     The ray's vertex must not lie in the plane of the ellipse.
C     The orthogonal projection of the point onto the plane should
C     yield a distinct vector.
C
      CALL VPRJP ( VERTEX, EPLANE, VPRJ )

      IF ( VDIST(VERTEX, VPRJ) .EQ. 0.D0  )  THEN

         CALL SETMSG ( 'Viewing point is in the plane of the ellipse.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                         )
         CALL CHKOUT ( 'ZZASRYEL'                                    )
         RETURN

      END IF

C
C     See whether the ray intersects the plane region bounded by the
C     ellipse.  If it does, set the limb angle sign to -1.  Otherwise
C     the sign is +1.
C
C     First, find the intersection of the ray and plane.
C
      CALL INRYPL ( VERTEX, DIR, EPLANE, NXPTS, XPT )

      IF ( NXPTS .EQ. INF )  THEN
C
C        We don't expect to hit this case since we've already tested
C        for the vertex lying in the ellipse plane.  However,
C        variations in round-off error make this case possible though
C        unlikely.
C
         CALL SETMSG ( 'Ray lies in the plane of the ellipse.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                 )
         CALL CHKOUT ( 'ZZASRYEL'                              )
         RETURN

      END IF

C
C     Give NPT an initial value.
C
      NPT = BIGNPT

      IF ( NXPTS .EQ. 0 ) THEN
C
C        The ray does not intersect the plane.
C
         ASIGN = 1.D0

      ELSE
C
C        The ray intersects the plane.  We must determine if the
C        ray intersects the region bounded by the ellipse.
C
C        Find the coordinates of the intersection point in a frame
C        aligned with the axes of the ellipse and centered at
C        the ellipse's center.
C
         CALL VSUB ( XPT, CENTER, XOFF )

         ACOMP = VDOT ( XOFF, SMAJOR ) / A
         BCOMP = VDOT ( XOFF, SMINOR ) / B

C
C        Now find the "level curve parameter" LEVEL for the offset of
C        the intersection point from the ellipse's center.
C
         LEVEL =  ACOMP**2 / A**2   +   BCOMP**2 / B**2

         IF ( LEVEL .LE. 1.D0 ) THEN
C
C           The ray-plane intersection is on the ellipse or inside the
C           plane region bounded by the ellipse.
C
            ASIGN = -1.D0

         ELSE

            ASIGN =  1.D0

            IF ( DOMIN ) THEN
C
C              We have the exterior minimum case:  the ray doesn't
C              penetrate the plane region bounded by the ellipse,
C              and we're looking for an absolute minimum of angular
C              separation.  We can use a fairly small number of test
C              points on the limb and still find the location of
C              minimum angular separation.
C
               NPT = SMLNPT

            END IF

         END IF

      END IF
C
C     ASIGN has been set.
C

C
C     The limb is the set of points
C
C        CENTER   +   cos(theta) SMAJOR   +   sin(theta) SMINOR
C
C     where theta is in the interval (-pi, pi].
C
C     We want to find the value of `theta' for which the angular
C     separation of ray and ellipse is minimized (or maximized).  To
C     improve efficiency, instead of working with angular separation,
C     we'll find the extremum of a proxy function:  the distance
C     between the unit ray direction vector and the unit vector in the
C     direction from the ray's vertex to a selected point on the
C     ellipse.  This function doesn't require an arcsine evaluation,
C     and its extrema occur at the same locations as the extrema of the
C     angular separation.
C
C     We'll compute the proxy value for the angular separation of the
C     ray and limb at NPT different points on the limb, where the
C     points are generated by taking equally spaced values of theta.
C     We'll find the extremum of the proxy function on this set of
C     points, and then search for the absolute extremum.
C
C     To make our computations more efficient, we'll subtract off
C     the ellipse's center from the vertex position to obtain a
C     translated ellipse centered at the origin.
C
      CALL VSUB ( VERTEX, CENTER, V2 )

      IF ( DOMIN ) THEN
         EXTPRX = 2.D0
      ELSE
         EXTPRX = 0.D0
      END IF

      EXTIDX = 0

      P2     = TWOPI()
      DELTA  = P2 / NPT

      CALL VHAT ( DIR, UDIR )

      DO I = 0, NPT-1

         THETA  =  I * DELTA

         CALL VLCOM3 (  -1.D0,        V2,
     .                  COS(THETA),   SMAJOR,
     .                  SIN(THETA),   SMINOR,   DIFF  )

         CALL VHAT ( DIFF, UDIFF )

         PROXY = VDIST ( UDIFF, UDIR )

         IF ( DOMIN ) THEN

            IF ( PROXY .LT. EXTPRX ) THEN

               EXTIDX  =  I
               EXTPRX  =  PROXY

            END IF

         ELSE

            IF ( PROXY .GT. EXTPRX ) THEN

               EXTIDX  =  I
               EXTPRX  =  PROXY

            END IF

         END IF

      END DO

C
C     The extreme value of the proxy function is EXTPRX, and was
C     obtained at the test point indexed by EXTIDX.  We find the values
C     of the proxy function at the neighboring points and perform a
C     `golden section' search.
C
C     In the following section of code,
C
C        LOWER          is the lower bound of the interval in which
C                       the extremum is bracketed.
C
C        UPPER          is the upper bound of the interval in which
C                       the extremum is bracketed.
C
C        BTWEEN         is a point between LOWER and UPPER.  The proxy
C                       function value corresponding to the angle
C                       BTWEEN is less than the proxy function value
C                       corresponding to LOWER and UPPER.
C
C        NEWPT          is a point between LOWER and UPPER such that
C                                                                  ___
C                          BTWEEN - LOWER                  3  -  \/ 5
C                          --------------    =   GR   =    ------------
C                          UPPER  - LOWER                        2
C
C
      GR     =  (  3.D0 -  SQRT(5.D0)  )  /  2.D0

      LOWER  =  ( P2 / NPT )  *  ( EXTIDX - 1 )
      UPPER  =  ( P2 / NPT )  *  ( EXTIDX + 1 )

C
C     We're going to move LOWER and UPPER closer together at each
C     iteration of the following loop, thus trapping the extremum. The
C     invariant condition that we will maintain is that the proxy value
C     corresponding to the angle BTWEEN is less (or more) than the proxy
C     value for the limb points corresponding to LOWER and UPPER.
C
C     The loop terminates when the offset by which we adjust LOWER or
C     UPPER is smaller than our tolerance value. This offset is no
C     larger than the difference between LOWER and BTWEEN.
C
      BTWEEN  =  ( P2 / NPT )  *  EXTIDX

C
C     We'll give the names LOWPRX and UPRPRX to the proxy function
C     values at the limb points corresponding to LOWER and UPPER,
C     respectively. We don't actually have to evaluate these values,
C     however. They are useful for understanding the minimization
C     algorithm we'll use, but are not actually used in the code.
C
C     We already know that the proxy function value corresponding to
C     BTWEEN is EXTPRX; this was computed above.
C
      BTWPRX  =  EXTPRX

C
C     Before starting our loop, we're going to shift all of our angles
C     by 2*pi, so that they're bounded away from zero.
C
      LOWER   =  LOWER  + P2
      UPPER   =  UPPER  + P2
      BTWEEN  =  BTWEEN + P2

      NITR    = 0
      PROXY   = 3.D0

      DO WHILE (        (  NITR                .LE. MAXITR )
     .           .AND.  (  TOUCHD(UPPER-LOWER) .GT. TOL    )  )
C
C        At this point, the following order relations hold:
C
C           LOWER  <    BTWEEN    <   UPPER
C                  -              -
C
C           BTWPRX <  MIN ( LOWPRX, UPRPRX )
C                  -
C
C        Compute NEWPT.  This point is always located at the fraction
C        GR of the way into the larger of the intervals
C        [ LOWER, BTWEEN ] and [ BTWEEN, UPPER ].
C
C
         IF (  ( BTWEEN - LOWER )  .GT. ( UPPER - BTWEEN )  ) THEN

            NEWPT = LOWER   +  GR * ( BTWEEN - LOWER  )
         ELSE
            NEWPT = BTWEEN  +  GR * ( UPPER  - BTWEEN )
         END IF

C
C        We are going to shorten our interval by changing LOWER to
C        NEWPT or UPPER to BTWEEN, and if necessary, BTWEEN to NEWPT,
C        while maintaining the order relations of UPPER, LOWER, and
C        BTWEEN, and also the order relations of UPRPRX, LOWPRX, and
C        BTWPRX.  To do this, we need the proxy function value at
C        NEWPT.
C
         CALL VLCOM3 (  -1.D0,        V2,
     .                  COS(NEWPT),   SMAJOR,
     .                  SIN(NEWPT),   SMINOR,   DIFF  )

         CALL VHAT ( DIFF, UDIFF )

         PROXY = VDIST ( UDIFF, UDIR )

C
C        Swap NEWPT and BTWEEN if necessary, to ensure that
C
C           NEWPT  <  BTWEEN.
C                  _
C
         IF ( NEWPT .GT. BTWEEN ) THEN

            CALL SWAPD ( BTWEEN, NEWPT )
            CALL SWAPD ( BTWPRX, PROXY )

         END IF

         IF ( DOMIN ) THEN

            IF ( PROXY .GT. BTWPRX ) THEN

               LOWER  = NEWPT
            ELSE
               UPPER  = BTWEEN
               BTWEEN = NEWPT
               BTWPRX = PROXY
            END IF

         ELSE

            IF ( PROXY .LT. BTWPRX ) THEN

               LOWER  = NEWPT
            ELSE
               UPPER  = BTWEEN
               BTWEEN = NEWPT
               BTWPRX = PROXY
            END IF

         END IF

         NITR = NITR + 1

      END DO

C
C     At this point, LPT is a good estimate of the limb point at which
C     the extremum of the angular separation from the ray occurs.
C
      CALL VADD ( DIFF, V2, LPT )

C
C     Add the center back to LPT to find EXTPT on the original ellipse.
C
      CALL VADD ( CENTER, LPT, EXTPT )

C
C     Set the angular separation at EXTPT.
C
      ANGLE  =  VSEP( DIFF,  UDIR ) * ASIGN

      CALL CHKOUT ( 'ZZASRYEL' )
      RETURN
      END


      SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL,
     $                   N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2,
     $                   IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for a given open-loop model (A,B,C,D), and for
C     given state feedback gain F and full observer gain G,
C     such that A+B*F and A+G*C are stable, a reduced order
C     controller model (Ac,Bc,Cc,Dc) using a coprime factorization
C     based controller reduction approach. For reduction,
C     either the square-root or the balancing-free square-root
C     versions of the Balance & Truncate (B&T) or Singular Perturbation
C     Approximation (SPA) model reduction methods are used in
C     conjunction with stable coprime factorization techniques.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the open-loop system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears
C             in the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     JOBMR   CHARACTER*1
C             Specifies the model reduction approach to be used
C             as follows:
C             = 'B':  use the square-root B&T method;
C             = 'F':  use the balancing-free square-root B&T method;
C             = 'S':  use the square-root SPA method;
C             = 'P':  use the balancing-free square-root SPA method.
C
C     JOBCF   CHARACTER*1
C             Specifies whether left or right coprime factorization is
C             to be used as follows:
C             = 'L':  use left coprime factorization;
C             = 'R':  use right coprime factorization.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to perform a
C             preliminary equilibration before performing
C             order reduction as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     ORDSEL  CHARACTER*1
C             Specifies the order selection method as follows:
C             = 'F':  the resulting controller order NCR is fixed;
C             = 'A':  the resulting controller order NCR is
C                     automatically determined on basis of the given
C                     tolerance TOL1.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the open-loop state-space representation,
C             i.e., the order of the matrix A.  N >= 0.
C             N also represents the order of the original state-feedback
C             controller.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NCR     (input/output) INTEGER
C             On entry with ORDSEL = 'F', NCR is the desired order of
C             the resulting reduced order controller.  0 <= NCR <= N.
C             On exit, if INFO = 0, NCR is the order of the resulting
C             reduced order controller. NCR is set as follows:
C             if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR
C             is the desired order on entry, and NMIN is the order of a
C             minimal realization of an extended system Ge (see METHOD);
C             NMIN is determined as the number of
C             Hankel singular values greater than N*EPS*HNORM(Ge),
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the
C             extended system (computed in HSV(1));
C             if ORDSEL = 'A', NCR is equal to the number of Hankel
C             singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, if INFO = 0, the leading NCR-by-NCR part of this
C             array contains the state dynamics matrix Ac of the reduced
C             controller.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must
C             contain the original input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must
C             contain the original state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             If JOBD = 'D', the leading P-by-M part of this
C             array must contain the system direct input/output
C             transmission matrix D.
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
C             On entry, the leading M-by-N part of this array must
C             contain a stabilizing state feedback matrix.
C             On exit, if INFO = 0, the leading M-by-NCR part of this
C             array contains the state/output matrix Cc of the reduced
C             controller.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,P)
C             On entry, the leading N-by-P part of this array must
C             contain a stabilizing observer gain matrix.
C             On exit, if INFO = 0, the leading NCR-by-P part of this
C             array contains the input/state matrix Bc of the reduced
C             controller.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     DC      (output) DOUBLE PRECISION array, dimension (LDDC,P)
C             If INFO = 0, the leading M-by-P part of this array
C             contains the input/output matrix Dc of the reduced
C             controller.
C
C     LDDC    INTEGER
C             The leading dimension of array DC.  LDDC >= MAX(1,M).
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, it contains the N Hankel singular values
C             of the extended system ordered decreasingly (see METHOD).
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If ORDSEL = 'A', TOL1 contains the tolerance for
C             determining the order of the reduced extended system.
C             For model reduction, the recommended value is
C             TOL1 = c*HNORM(Ge), where c is a constant in the
C             interval [0.00001,0.001], and HNORM(Ge) is the
C             Hankel norm of the extended system (computed in HSV(1)).
C             The value TOL1 = N*EPS*HNORM(Ge) is used by default if
C             TOL1 <= 0 on entry, where EPS is the machine precision
C             (see LAPACK Library Routine DLAMCH).
C             If ORDSEL = 'F', the value of TOL1 is ignored.
C
C     TOL2    DOUBLE PRECISION
C             The tolerance for determining the order of a minimal
C             realization of the coprime factorization controller
C             (see METHOD). The recommended value is
C             TOL2 = N*EPS*HNORM(Ge) (see METHOD).
C             This value is used by default if TOL2 <= 0 on entry.
C             If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK = 0,         if ORDSEL = 'F' and NCR = N.
C                                                 Otherwise,
C             LIWORK = MAX(PM,M), if JOBCF = 'L',
C             LIWORK = MAX(PM,P), if JOBCF = 'R', where
C             PM = 0,             if JOBMR = 'B',
C             PM = N,             if JOBMR = 'F',
C             PM = MAX(1,2*N),    if JOBMR = 'S' or 'P'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise,
C             LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L',
C             LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R',
C             where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  with ORDSEL = 'F', the selected order NCR is
C                   greater than the order of a minimal
C                   realization of the controller.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction of A+G*C to a real Schur form
C                   failed;
C             = 2:  the matrix A+G*C is not stable (if DICO = 'C'),
C                   or not convergent (if DICO = 'D');
C             = 3:  the computation of Hankel singular values failed;
C             = 4:  the reduction of A+B*F to a real Schur form
C                   failed;
C             = 5:  the matrix A+B*F is not stable (if DICO = 'C'),
C                   or not convergent (if DICO = 'D').
C
C     METHOD
C
C     Let be the linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t) + Du(t),                             (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let Go(d) be the open-loop
C     transfer-function matrix
C                           -1
C          Go(d) = C*(d*I-A) *B + D .
C
C     Let F and G be the state feedback and observer gain matrices,
C     respectively, chosen so that A+B*F and A+G*C are stable matrices.
C     The controller has a transfer-function matrix K(d) given by
C                                        -1
C          K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G .
C
C     The closed-loop transfer-function matrix is given by
C                                     -1
C          Gcl(d) = Go(d)(I+K(d)Go(d)) .
C
C     K(d) can be expressed as a left coprime factorization (LCF),
C                          -1
C          K(d) = M_left(d) *N_left(d) ,
C
C     or as a right coprime factorization (RCF),
C                                      -1
C          K(d) = N_right(d)*M_right(d) ,
C
C     where M_left(d), N_left(d), N_right(d), and M_right(d) are
C     stable transfer-function matrices.
C
C     The subroutine SB16BD determines the matrices of a reduced
C     controller
C
C          d[z(t)] = Ac*z(t) + Bc*y(t)
C          u(t)    = Cc*z(t) + Dc*y(t),                           (2)
C
C     with the transfer-function matrix Kr as follows:
C
C     (1) If JOBCF = 'L', the extended system
C         Ge(d)  = [ N_left(d) M_left(d) ] is reduced to
C         Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the
C         B&T or SPA methods. The reduced order controller Kr(d)
C         is computed as
C                           -1
C         Kr(d) = M_leftr(d) *N_leftr(d) ;
C
C     (2) If JOBCF = 'R', the extended system
C         Ge(d) = [ N_right(d) ] is reduced to
C                 [ M_right(d) ]
C         Ger(d) = [ N_rightr(d) ] by using either the
C                  [ M_rightr(d) ]
C         B&T or SPA methods. The reduced order controller Kr(d)
C         is computed as
C                                         -1
C         Kr(d) = N_rightr(d)* M_rightr(d) .
C
C     If ORDSEL = 'A', the order of the controller is determined by
C     computing the number of Hankel singular values greater than
C     the given tolerance TOL1. The Hankel singular values are
C     the square roots of the eigenvalues of the product of
C     the controllability and observability Grammians of the
C     extended system Ge.
C
C     If JOBMR = 'B', the square-root B&T method of [1] is used.
C
C     If JOBMR = 'F', the balancing-free square-root version of the
C     B&T method [1] is used.
C
C     If JOBMR = 'S', the square-root version of the SPA method [2,3]
C     is used.
C
C     If JOBMR = 'P', the balancing-free square-root version of the
C     SPA method [2,3] is used.
C
C     REFERENCES
C
C     [1] Tombs, M.S. and Postlethwaite, I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     [2] Varga, A.
C         Efficient minimal realization procedure based on balancing.
C         Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
C         A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2,
C         pp. 42-46, 1991.
C
C     [3] Varga, A.
C         Coprime factors model reduction method based on square-root
C         balancing-free techniques.
C         System Analysis, Modelling and Simulation, Vol. 11,
C         pp. 303-311, 1993.
C
C     [4] Liu, Y., Anderson, B.D.O. and Ly, O.L.
C         Coprime factorization controller reduction with Bezout
C         identity induced frequency weighting.
C         Automatica, vol. 26, pp. 233-249, 1990.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on accuracy enhancing square-root or
C     balancing-free square-root techniques.
C                                         3
C     The algorithms require less than 30N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000.
C     D. Sima, University of Bucharest, August 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C              Aug. 2001.
C
C     KEYWORDS
C
C     Balancing, controller reduction, coprime factorization,
C     minimal realization, multivariable system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDD, LDDC,
     $                  LDF, LDG, LDWORK, M, N, NCR, P
      DOUBLE PRECISION  TOL1, TOL2
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*)
C     .. Local Scalars ..
      CHARACTER         JOB
      LOGICAL           BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA,
     $                  WITHD
      INTEGER           KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2,
     $                  LWR, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD,
     $                  SB08HD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO   = 0
      IWARN  = 0
      DISCR  = LSAME( DICO,   'D' )
      WITHD  = LSAME( JOBD,   'D' )
      BTA    = LSAME( JOBMR,  'B' ) .OR. LSAME( JOBMR, 'F' )
      SPA    = LSAME( JOBMR,  'S' ) .OR. LSAME( JOBMR, 'P' )
      BAL    = LSAME( JOBMR,  'B' ) .OR. LSAME( JOBMR, 'S' )
      LEFT   = LSAME( JOBCF,  'L' )
      LEQUIL = LSAME( EQUIL,  'S' )
      FIXORD = LSAME( ORDSEL, 'F' )
C
      LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 )
      LW1 = (N+M)*(M+P) + MAX( LWR, 4*M )
      LW2 = (N+P)*(M+P) + MAX( LWR, 4*P )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -5
      ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN
         INFO = -6
      ELSE IF( N.LT.0 ) THEN
         INFO = -7
      ELSE IF( M.LT.0 ) THEN
         INFO = -8
      ELSE IF( P.LT.0 ) THEN
         INFO = -9
      ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN
         INFO = -10
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -18
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -20
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -22
      ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN
         INFO = -24
      ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN
         INFO = -27
      ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND.
     $         ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR.
     $      ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR.
     $      ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN
         INFO = -30
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB16BD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 .OR.
     $    ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN
         NCR = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( NCR.EQ.N ) THEN
C
C        Form the controller state matrix,
C        Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) .
C        Real workspace:    need  P*N.
C        Integer workspace: need  0.
C
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P )
         IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M,
     $                          ONE, D, LDD, F, LDF, ONE,
     $                          DWORK, P )
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G,
     $               LDG, DWORK, P, ONE, A, LDA )
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B,
     $               LDB, F, LDF, ONE, A, LDA )
C
         DWORK(1) = P*N
         RETURN
      END IF
C
      IF( BAL ) THEN
         JOB = 'B'
      ELSE
         JOB = 'N'
      END IF
C
C     Reduce the coprime factors.
C
      IF( LEFT ) THEN
C
C        Form Ge(d) = [ N_left(d) M_left(d) ] as
C
C             ( A+G*C |  G  B+GD )
C             (------------------)
C             (   F   |  0   I   )
C
C        Real workspace:    need  (N+M)*(M+P).
C        Integer workspace: need  0.
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G,
     $               LDG, C, LDC, ONE, A, LDA )
         KBE  = 1
         KDE  = KBE + N*(P+M)
         LDBE = MAX( 1, N )
         LDDE = M
         CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE )
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE )
         IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P,
     $                          ONE, G, LDG, D, LDD, ONE,
     $                          DWORK(KBE+N*P), LDBE )
         CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE )
         CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE )
C
C        Compute the reduced coprime factors,
C             Ger(d) = [ N_leftr(d) M_leftr(d) ] ,
C        by using either the B&T or SPA methods.
C
C        Real workspace:    need  (N+M)*(M+P) +
C                                 MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2).
C        Integer workspace: need  0,         if JOBMR = 'B',
C                                 N,         if JOBMR = 'F', and
C                                 MAX(1,2*N) if JOBMR = 'S' or 'P'.
C
         KW = KDE + M*(P+M)
         IF( BTA ) THEN
            CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A,
     $                   LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1,
     $                   IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO )
         ELSE
            CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A,
     $                   LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE),
     $                   LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW),
     $                   LDWORK-KW+1, IWARN, INFO )
         END IF
         IF( INFO.NE.0 )
     $      RETURN
C
         WRKOPT = INT( DWORK(KW) ) + KW - 1
C
C        Compute the reduced order controller,
C                             -1
C           Kr(d) = M_leftr(d)  *N_leftr(d).
C
C        Real workspace:    need  (N+M)*(M+P) + MAX(1,4*M).
C        Integer workspace: need  M.
C
         CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF,
     $                DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE,
     $                DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO )
C
C        Copy the reduced system matrices Bc and Dc.
C
         CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG )
         CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC )
C
      ELSE
C
C        Form Ge(d) = [ N_right(d) ]
C                     [ M_right(d) ] as
C
C             ( A+B*F | G )
C             (-----------)
C             (   F   | 0 )
C             ( C+D*F | I )
C
C        Real workspace:    need  (N+P)*(M+P).
C        Integer workspace: need  0.
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B,
     $               LDB, F, LDF, ONE, A, LDA )
         KCE  = 1
         KDE  = KCE + N*(P+M)
         LDCE = M+P
         LDDE = LDCE
         CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE )
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE )
         IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M,
     $                          ONE, D, LDD, F, LDF, ONE,
     $                          DWORK(KCE+M), LDCE )
         CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE )
         CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE )
C
C        Compute the reduced coprime factors,
C             Ger(d) = [ N_rightr(d) ]
C                      [ M_rightr(d) ],
C        by using either the B&T or SPA methods.
C
C        Real workspace:    need  (N+P)*(M+P) +
C                                 MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2).
C        Integer workspace: need  0,         if JOBMR = 'B',
C                                 N,         if JOBMR = 'F', and
C                                 MAX(1,2*N) if JOBMR = 'S' or 'P'.
C
         KW = KDE + P*(P+M)
         IF( BTA ) THEN
            CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A,
     $                   LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1,
     $                   IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO )
         ELSE
            CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A,
     $                   LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE),
     $                   LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW),
     $                   LDWORK-KW+1, IWARN, INFO )
         END IF
         IF( INFO.NE.0 ) THEN
            IF( INFO.NE.3 ) INFO = INFO + 3
            RETURN
         END IF
C
         WRKOPT = INT( DWORK(KW) ) + KW - 1
C
C        Compute the reduced order controller,
C                                        -1
C           Kr(d) = N_rightr(d)*M_rightr(d) .
C
C        Real workspace:    need  (N+P)*(M+P) + MAX(1,4*P).
C        Integer workspace: need  P.
C
         CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE,
     $                DWORK(KDE), LDDE, DWORK(KCE+M), LDCE,
     $                DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO )
C
C        Copy the reduced system matrices Cc and Dc.
C
         CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF )
         CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC )
C
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB16BD ***
      END


      SUBROUTINE DISKFBB(EAR,NE,PARAM,IDT,PHOTAR,PHOTER)

      INTEGER NE, IDT
      REAL    EAR(0:NE), PARAM(2), PHOTAR(NE), PHOTER(NE)

c     Multicolour disk blackbody model used in ISAS, Japan.
c     See Mitsuda et al. PASJ, 36, 741 (1984)
c     & Makishima et al. ApJ 308, 635 1986)
c     Ken Ebisawa 1992/12/22

C     Modified to use double precision and to make numerical
C     integration faster.
C     Ken Ebisawa 1993/07/29

C     Modified the algorithm. by Kazuhisa MITSUDA May 31, 1994
C     A numerical calculation was first done within an accruacy of 0.01 %.
C     Then an interpolation formula was found.
C     The interpolation is precise within 1e-5 level.
c
c     Edited by Abigail Stevens, 25 Apr 2016
c     Now has spectral hardening factor f

      INTEGER I, J
      REAL XN, XH, f

      double precision TIN, E, photon

C     These coefficients are taken from the spectral fitting program SPFD
C     in ISAS.
C     These are used for Gaussian Integral in the given energy band

      DOUBLE PRECISION  GAUSS(5,2)

      SAVE GAUSS

      DATA  GAUSS /
     $     0.236926885,  0.478628670, 0.568888888, 0.478628670,
     $     0.236926885, -0.906179846, -0.538469310, 0.0,  0.538469310,
     $     0.906179846 /

c suppress a warning message from the compiler
      i = idt

c this model has no errors
      DO I = 1, NE
         PHOTER(I) = 0.0
      ENDDO
c f is the spectral hardening factor (f = Tcol / Teff)
c TIN starts as Teff (since that's what we want to fit for/find)
	  f = PARAM(2)
      TIN = DBLE(PARAM(1)) * f
c Now TIN is Tcol

      DO 100 I = 1, NE
         XN = (EAR(I)-EAR(I-1))/2.0
         PHOTAR(I) = 0.0
         XH = XN + EAR(I-1)
         DO 200 J = 1, 5
            E = DBLE(XN) * GAUSS(J,2) + DBLE(XH)
            CALL mcdspc(E, TIN, 1.0d0, PHOTON)
            PHOTAR(I) = PHOTAR(I) + REAL(GAUSS(J,1) * PHOTON)
 200     CONTINUE
c         PHOTAR(I) = PHOTAR(I) * XN
c	Need to divide by f^4 to account for using Tcol instead of Teff
         PHOTAR(I) = PHOTAR(I) * XN / f**4

 100  CONTINUE
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes nodal values for ratiotional, strain and stress tensor.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn number of 1-D Legendre nodes
!> @param[in] ct GLL nodes
!> @param[in] ww GLL weights
!> @param[in] dd matrix of spectral derivatives
!> @param[in] alfa11 costant for the bilinear map
!> @param[in] alfa12 costant for the bilinear map
!> @param[in] alfa13 costant for the bilinear map
!> @param[in] alfa21 costant for the bilinear map
!> @param[in] alfa22 costant for the bilinear map
!> @param[in] alfa23 costant for the bilinear map
!> @param[in] alfa31 costant for the bilinear map
!> @param[in] alfa32 costant for the bilinear map
!> @param[in] alfa33 costant for the bilinear map
!> @param[in] beta11 costant for the bilinear map
!> @param[in] beta12 costant for the bilinear map
!> @param[in] beta13 costant for the bilinear map
!> @param[in] beta21 costant for the bilinear map
!> @param[in] beta22 costant for the bilinear map
!> @param[in] beta23 costant for the bilinear map
!> @param[in] beta31 costant for the bilinear map
!> @param[in] beta32 costant for the bilinear map
!> @param[in] beta33 costant for the bilinear map
!> @param[in] gamma1  costant for the bilinear map
!> @param[in] gamma2  costant for the bilinear map
!> @param[in] gamma3  costant for the bilinear map
!> @param[in] delta1  costant for the bilinear map
!> @param[in] delta2  costant for the bilinear map
!> @param[in] delta3  costant for the bilinear map
!> @param[in] ux x-displacement
!> @param[in] uy y-displacement
!> @param[in] uy z-displacement
!> @param[in] div duxdx + duydy + duzdz
!> @param[in] lambda nodal values of Lame coefficient lambda
!> @param[in] mu nodal values of Lame coefficient mu
!> @param[out] rotx  nodal values of rotational tensor x-axis
!> @param[out] roty  nodal values of rotational tensor y-axis
!> @param[out] rotz  nodal values of rotational tensor z-axis
!> @param[out] strainxx nodal values of strain tensor
!> @param[out] strainyy nodal values of strain tensor
!> @param[out] strainzz nodal values of strain tensor
!> @param[out] strainxy nodal values of strain tensor
!> @param[out] strainyz nodal values of strain tensor
!> @param[out] strainzx nodal values of strain tensor
!> @param[out] stressxx nodal values of stress tensor
!> @param[out] stressyy nodal values of stress tensor
!> @param[out] stresszz nodal values of stress tensor
!> @param[out] stressxy nodal values of stress tensor
!> @param[out] stressyz nodal values of stress tensor
!> @param[out] stresszx nodal values of stress tensor

      subroutine MAKE_STRAIN_ROT_STRESS_TENSOR(nn,ct,ww,dd,&
                                        alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,&
                                        alfa31,alfa32,alfa33,beta11,beta12,beta13,&
                                        beta21,beta22,beta23,beta31,beta32,beta33,&
                                        gamma1,gamma2,gamma3,delta1,delta2,delta3,&
                                        ux,uy,uz,div,&
                                        lambda,mu,&
                                        rotx,roty,rotz,&
                                        strainxx,strainyy,strainzz,&
                                        strainxy,strainyz,strainzx,&
                                        stressxx,stressyy,stresszz,&
                                        stressxy,stressyz,stresszx)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k,p,q,r,L

      real*8 :: alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,alfa31,alfa32,alfa33
      real*8 :: beta11,beta12,beta13,beta21,beta22,beta23,beta31,beta32,beta33
      real*8 :: gamma1,gamma2,gamma3,delta1,delta2,delta3,dphi,phi
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8 :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz
      real*8 :: t1ux,t2ux,t3ux,t1uy,t2uy,t3uy,t1uz,t2uz,t3uz, dpdcsi, dpdeta, dpdzeta

      real*8, dimension(nn) :: ct,ww

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: ux,uy,uz
      real*8, dimension(nn,nn,nn) :: div,rotx,roty,rotz
      real*8, dimension(nn,nn,nn) :: strainxx,strainyy,strainzz
      real*8, dimension(nn,nn,nn) :: strainxy,strainyz,strainzx
      real*8, dimension(nn,nn,nn) :: stressxx,stressyy,stresszz
      real*8, dimension(nn,nn,nn) :: stressxy,stressyz,stresszx
      real*8, dimension(nn,nn,nn) :: lambda,mu

      real*8, dimension(nn**3) :: derx, dery, derz, ux_el, uy_el, uz_el

!     STRESS CALCULATION

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn
               !M = p + (q-1)*nn + (r-1)*nn*nn

                do k = 1, nn
                  do j = 1, nn
                     do i = 1, nn
                        L = i + (j-1)*nn + (k-1)*nn*nn

                      ux_el(L) = ux(i,j,k)
                      uy_el(L) = uy(i,j,k)
                      uz_el(L) = uz(i,j,k)

                       dxdx = alfa11 + beta12*ct(r) + beta13*ct(q) &
                            + gamma1*ct(q)*ct(r)
                       dydx = alfa21 + beta22*ct(r) + beta23*ct(q) &
                            + gamma2*ct(q)*ct(r)
                       dzdx = alfa31 + beta32*ct(r) + beta33*ct(q) &
                            + gamma3*ct(q)*ct(r)

                       dxdy = alfa12 + beta11*ct(r) + beta13*ct(p) &
                            + gamma1*ct(r)*ct(p)
                       dydy = alfa22 + beta21*ct(r) + beta23*ct(p) &
                            + gamma2*ct(r)*ct(p)
                       dzdy = alfa32 + beta31*ct(r) + beta33*ct(p) &
                            + gamma3*ct(r)*ct(p)

                       dxdz = alfa13 + beta11*ct(q) + beta12*ct(p) &
                            + gamma1*ct(p)*ct(q)
                       dydz = alfa23 + beta21*ct(q) + beta22*ct(p) &
                            + gamma2*ct(p)*ct(q)
                       dzdz = alfa33 + beta31*ct(q) + beta32*ct(p) &
                            + gamma3*ct(p)*ct(q)

                       det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                             - dydz * (dxdx*dzdy - dzdx*dxdy) &
                             + dzdz * (dxdx*dydy - dydx*dxdy)

                      dpdcsi   = dphi(nn-1, ct(p), ct(i)) * phi(nn-1, ct(q), ct(j)) * phi(nn-1, ct(r), ct(k))
                          dpdeta   = phi(nn-1, ct(p), ct(i)) * dphi(nn-1, ct(q), ct(j)) * phi(nn-1, ct(r), ct(k))
                    dpdzeta = phi(nn-1, ct(p), ct(i)) * phi(nn-1, ct(q), ct(j)) * dphi(nn-1, ct(r), ct(k))

                         derx(L) = (dydx*(dzdy*dpdzeta - dzdz*dpdeta) - dydy*(dzdx*dpdzeta - dzdz*dpdcsi) + &
                             dydz*(dzdx*dpdeta - dzdy*dpdcsi))/det_j

                    dery(L) = (dzdx*(dxdy*dpdzeta - dxdz*dpdeta) - dzdy*(dxdx*dpdzeta - dxdz*dpdcsi) + &
                             dzdz*(dxdx*dpdeta - dxdy*dpdcsi))/det_j

                    derz(L) = (dxdx*(dydy*dpdzeta - dydz*dpdeta) - dxdy*(dydx*dpdzeta - dydz*dpdcsi) +  &
                             dxdz*(dydx*dpdeta - dydy*dpdcsi))/det_j

                    enddo
                  enddo
                enddo

               strainxx(p,q,r) = dot_product(derx,ux_el)
               strainyy(p,q,r) = dot_product(dery,uy_el)
               strainyy(p,q,r) = dot_product(derz,uz_el)
               strainxy(p,q,r) = 0.5d0*(dot_product(derx,uy_el) + dot_product(dery,ux_el))
               strainyz(p,q,r) = 0.5d0*(dot_product(derz,uy_el) + dot_product(dery,uz_el))
               strainzx(p,q,r) = 0.5d0*(dot_product(derx,uz_el) + dot_product(derz,ux_el))

               rotx(p,q,r) = 0.5d0*(dot_product(dery,uz_el) - dot_product(derz,uy_el))
               roty(p,q,r) = 0.5d0*(dot_product(derz,ux_el) - dot_product(derx,uz_el))
               rotz(p,q,r) = 0.5d0*(dot_product(derx,uy_el) - dot_product(dery,ux_el))

               stressxx(p,q,r) = lambda(p,q,r) * (dot_product(derx,ux_el) + dot_product(dery,uy_el) &
                                + dot_product(derz,uz_el)) + 2.0d0*mu(p,q,r) * dot_product(derx,ux_el)
               stressyy(p,q,r) = lambda(p,q,r) * (dot_product(derx,ux_el) + dot_product(dery,uy_el) &
                                + dot_product(derz,uz_el)) + 2.0d0*mu(p,q,r) * dot_product(dery,uy_el)
               stresszz(p,q,r) = lambda(p,q,r) * (dot_product(derx,ux_el) + dot_product(dery,uy_el) &
                                + dot_product(derz,uz_el)) + 2.0d0*mu(p,q,r) * dot_product(derz,uz_el)

               stressyz(p,q,r) = mu(p,q,r) * (dot_product(derz,uy_el) + dot_product(dery,uz_el))
               stresszx(p,q,r) = mu(p,q,r) * (dot_product(derx,uz_el) + dot_product(derz,ux_el))
               stressxy(p,q,r) = mu(p,q,r) * (dot_product(derx,uy_el) + dot_product(dery,ux_el))

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_STRAIN_ROT_STRESS_TENSOR


C    %W% %G%
      subroutine cvsol(icv, base, xi, xo)

      implicit none

      include 'tspinc/params.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/cv.inc'

      integer icv, idat, i
      real    xi, xo, xipu, xopu, base

c     abort if icv .eq. 0
      if (icv.eq.0) then
        xo = xi
        return
      endif

c     process hardcoded curves (icv < 0)
      if (icv.lt.0) then

        idat = abs(icv)

        xipu = xi/base

        if (xipu.le.inpt(idat,1)) then
          xopu = outpt(idat,1)
        else if (xipu.ge.inpt(idat,totalpts(idat))) then
          xopu = outpt(idat,totalpts(idat))
        else
          do i = 2, totalpts(idat)
            if (xipu.lt.inpt(idat,i)) then
c             interpolate between i-1 and i
              xopu =   outpt(idat,i-1) + (xipu - inpt(idat,i-1))
     &                               *(outpt(idat,i) - outpt(idat,i-1))
     &                               /(inpt(idat,i)  - inpt(idat,i-1) )
              xo = xopu*base
              return
            endif
          enddo
        endif
        xo = xopu*base
        return
      endif

c     get index to cvin and cvout arrays
      idat = cvindx(icv)

c     compute output
      if (xi.le.cvin(idat+1)) then
        xo = cvout(idat+1)
      else if (xi.ge.cvin(idat+cvpts(icv))) then
        xo = cvout(idat+cvpts(icv))
      else
        do i = 2, cvpts(icv)
          if (xi.lt.cvin(idat+i)) then
c           interpolate between i-1 and i
            xo = cvout(idat+i-1) + (xi - cvin(idat+i-1) )
     &                            * ( cvout(idat+i) - cvout(idat+i-1) )
     &                            / ( cvin(idat +i) - cvin(idat+ i-1) )
            return
          endif
        enddo
      endif

      end


!
! Copyright (c) 2006-2007      University of Houston. All rights reserved.
! $COPYRIGHT$
!
! Additional copyrights may follow
!
! $HEADER$
!
        subroutine System_Precon ( ierror )

!...Vorkonditionierung der Matrix durch ein einfaches Jakobi-
!   Verfahren. Dabei wird die Hauptdiagonale als einfachste
!   Naeherung der Matrix genommen und invertiert.

        USE globale_daten
        USE matrix
        USE rechte_seite
        USE ergebnis
        USE numerik_daten

        implicit none

        integer :: ierror, i, j, k
        double precision, dimension ( dmiu:dmio, dmju:dmjo, dmku:dmko, nc ) :: precon_m

        precon_text = ' Preconditioning : Jakobi'

!...Austellen und gleichzeitiges Invertieren der Preconditionierungsmatrix

        do k = dmku, dmko
           do j = dmju, dmjo
              do i = dmiu, dmio
                 if ( rm000(i, j, k, 1, 1 ).ne.0.0 ) then
                    precon_m ( i, j, k, 1 ) = 1.0 /  &
                        rm000(i, j, k, 1, 1 )
                 else
                    precon_m ( i, j, k, 1 ) = 0.0
                 end if
              end do
           end do
        end do

!...Multiplizieren der rechten Seite und der Matrixdiagonalen
!   mit der Preconditionierungsmatrix

        call System_Precon_Matset ( precon_m, ierror)

        return
        end

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

        subroutine System_Precon_Matset ( precon_m , ierror )

!...Nach dem berechnen der Vorkonditionierungsmatrix, muss die Matrix
!   mit der inversen multipliziert werden. Aufgrund der einfachen
!   Struktur der Matrix und der Vorkonditionierungsmatrix
!   wird das Diagonale fuer Diagonale erledigt

        USE globale_daten
        USE matrix
        USE rechte_seite

        implicit none

        double precision, dimension ( dmiu:dmio, dmju:dmjo, dmku:dmko, nc ) :: &
             precon_m

        integer :: i, j, k, ierror

        do k = dmku, dmko
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rhs(i, j, k, 1) = rhs(i, j, k, 1) * &
                     precon_m ( i, j, k, 1 )
              end do
           end do
        end do

        do k = dmku, dmko
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rm000(i, j, k, 1, 1) = rm000(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rmb00(i, j, k, 1, 1) = rmb00(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rmf00(i, j, k, 1, 1) = rmf00(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rm0b0(i, j, k, 1, 1) = rm0b0(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rm0f0(i, j, k, 1, 1) = rm0f0(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rm00b(i, j, k, 1, 1) = rm00b(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
                 rm00f(i, j, k, 1, 1) = rm00f(i, j, k, 1, 1) * &
                     precon_m ( i, j, k, 1 )
              end do
           end do
        end do
!	write (*,*)
!	write (*,*) '================='
!        write (*,*) 'System_Precon()'
!	write (*,*) rm000(1,1,1,1,1), 'rm000(1,1,1,1,1)'
!	write (*,*) rmb00(1,1,1,1,1), 'rmb00(1,1,1,1,1)'
!	write (*,*) rmf00(1,1,1,1,1), 'rmf00(1,1,1,1,1)'
!	write (*,*) rm0b0(1,1,1,1,1), 'rm0b0(1,1,1,1,1)'
!	write (*,*) rm0f0(1,1,1,1,1), 'rm0f0(1,1,1,1,1)'
!	write (*,*) rm00b(1,1,1,1,1), 'rm00b(1,1,1,1,1)'
!	write (*,*) rm00f(1,1,1,1,1), 'rm00f(1,1,1,1,1)'
!	write (*,*) precon_m(1,1,1,1), 'precon_m(1,1,1,1,1)'
!	write (*,*) rhs(3,3,3,1), 'rhs(3,3,3,3,1)'
!	write (*,*)
!	write (*,*) '================='

        ierror = 0

        return
        end


      SUBROUTINE COVAR(ISOLV,R,ILAB,C)
C
C*** MODIFIED FOR VAX 01/31/84 BWF ***
C
      DOUBLE PRECISION C(ISOLV,ISOLV),R(1),OUT(12)
      INTEGER ILAB(1)
C
C
      JJ=0
      JK=0
C
      DO 3 IROW=1,ISOLV
      JK=JK+IROW
      J2=JK
      JS2=J2
      JJ=JK-IROW
C
      DO 2 ICOL=IROW,ISOLV
      JJ=JJ+ICOL
      J=JJ
      C(IROW,ICOL)=0.0D0
C
      DO 1 IADD=ICOL,ISOLV
      C(IROW,ICOL)=C(IROW,ICOL) + R(J) * R(J2)
C
      J=J+IADD
      J2=J2+IADD
    1 CONTINUE
C
      JS2=JS2+ICOL
      J2=JS2
    2 CONTINUE
C     JJ=0
    3 CONTINUE
C
C
C ********************
C      INCLUDE 'CVD/LIST'  ! CONTENT OF CVD INCLUDED BELOW
C ********************
C BEGIN CVD
C ********************
      ICOUNT=0
      IFLAG=0
      JMIN=1
      JMAX=12
      IF (ISOLV.LT.JMAX) JMAX=ISOLV
      IC=1
      L=ISOLV
      IF (ISOLV.GT.12) L=12
      M=L
    9 IK=0
      WRITE(6,200)
      WRITE(6,210) (ILAB(MX),MX=IC,L)
      DO 7 J=JMIN,JMAX
      IF (IFLAG.EQ.0) KK=M
      IF (IFLAG.EQ.1) KK=12
      IF (IC.GT.1) KK=KK+(12*ICOUNT)
      DO 6 I=IC,KK
      IK=IK+1
      OUT(IK)=C(J,I)
    6 CONTINUE
      WRITE(6,220) ILAB(J),(OUT(MX),MX=1,IK)
      IK=0
    7 CONTINUE
      IF (ISOLV.LE.JMAX.AND.ISOLV.LE.L) GOTO 10
      IF (ISOLV.LE.JMAX) GOTO 8
      JMIN=JMIN+12
      IF (ISOLV.GT.JMAX) IFLAG=1
      IF (ISOLV.GT.JMAX) JMAX=JMAX+12
      IF (ISOLV.LT.JMAX) JMAX=ISOLV
      GOTO 9
    8 CONTINUE
      ICOUNT=ICOUNT+1
      IFLAG=0
      JMIN=1+ICOUNT*12
      JMAX=12+ICOUNT*12
      IF (ISOLV.LE.JMAX) JMAX=ISOLV
      L=L+12
      IC=IC+12
      IF (L.GT.ISOLV) L=ISOLV
      IF (IC.GT.ISOLV) GOTO 10
      GOTO 9
   10 CONTINUE
C
  200 FORMAT(1H1)
  210 FORMAT(1H0,6X,12(2X,I5,3X))
  220 FORMAT(1H0,I6,12D10.3)
C ********************
C END CVD
C ********************
      DO 12 MC=1,ISOLV
      DO 11 MR=2,ISOLV
      IF(MR.EQ.MC) GO TO 11
      C(MR,MC)=C(MC,MR)
   11 CONTINUE
   12 CONTINUE
C
C
      RETURN
      END


! =============================================================================
!                       Test ellipse multi merge
!
!         This unit test checks the symmetry by performing a mirrored
!         group-merge (mirror axis x).
! =============================================================================
program test_ellipse_multi_merge_symmetry
    use unit_test
    use constants, only : pi, one, two, three, four, five
    use parcel_container
    use parcel_interpl, only : vol2grid_symmetry_error, sym_vol2grid_timer
    use parcel_nearest, only : merge_nearest_timer, merge_tree_resolve_timer
    use parcel_merge, only : merge_ellipses, merge_timer
    use options, only : parcel
    use parameters, only : update_parameters, lower, extent, nx, nz
    use fields, only : sym_volg
    use parcel_ellipse
    use timer
    implicit none

    double precision :: error

    nx = 2
    nz = 2
    lower  = (/-pi / two, -pi /two/)
    extent = (/pi, pi/)

    call register_timer('parcel merge', merge_timer)
    call register_timer('symmetric vol2grid', sym_vol2grid_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = three

    call update_parameters

    allocate(sym_volg(-1:nz+1, 0:nx-1))

    call parcel_alloc(6)

    call parcel_setup

    call merge_ellipses(parcels)

    ! check result
    error = eval_max_error()

    call print_result_dp('Test ellipse group-merge symmetry', error)

    call parcel_dealloc

    deallocate(sym_volg)

    contains

        subroutine parcel_setup
            double precision :: a1b1, a2b2
            integer :: n

            a1b1 = 1.44d0
            a2b2 = 0.25d0

            n_parcels = 6
            parcels%position(1, 1) = -f12
            parcels%position(2, 1) = 0.2d0
            parcels%volume(1) = a1b1 * pi
            parcels%B(1, 1) = 1.2d0 * a1b1
            parcels%B(2, 1) = -0.4d0

            parcels%position(1, 2) = -0.6d0
            parcels%position(2, 2) = 0.3d0
            parcels%volume(2) = a2b2 * pi
            parcels%B(1, 2) = 0.8d0 * a2b2
            parcels%B(2, 2) = f12

            parcels%position(1, 3) = -0.3d0
            parcels%position(2, 3) = -0.1d0
            parcels%volume(3) = a2b2 * pi
            parcels%B(1, 3) = 0.9d0 * a2b2
            parcels%B(2, 3) = -0.1d0

            !
            ! mirrored parcels
            !
            do n = 1, 3
                parcels%position(1, 3+n) = -parcels%position(1, n)
                parcels%position(2, 3+n) =  parcels%position(2, n)
                parcels%volume(3+n) = parcels%volume(n)
                parcels%B(1, 3+n) =  parcels%B(1, n)
                parcels%B(2, 3+n) = -parcels%B(2, n)
            enddo

        end subroutine parcel_setup

        function eval_max_error() result(max_err)
            double precision :: max_err

            max_err = zero
            max_err = max(max_err, abs(dble(n_parcels - 2)))

            call vol2grid_symmetry_error

            max_err = max(max_err, maxval(abs(sym_volg)))

        end function eval_max_error

end program test_ellipse_multi_merge_symmetry


! Check that parameters are correct intercepted.
! Specifically that types of constants without
! compound kind specs are correctly inferred
! adapted Gibbs iteration code from pymc
! for this test case
subroutine foo_non_compound_int(x)
  implicit none
  integer, parameter :: ii = selected_int_kind(9)

  integer(ii)   maxiterates
  parameter (maxiterates=2)

  integer(ii)   maxseries
  parameter (maxseries=2)

  integer(ii)   wasize
  parameter (wasize=maxiterates*maxseries)
  integer(ii), intent(inout) :: x
  dimension x(wasize)

  x(1) = x(1) + x(2) + x(3) + x(4) * wasize
  return
end subroutine


module compare
implicit none

private
public :: dummy_compare
public :: EqualTo, GreaterThan, LessThan, GreaterThanEq, LessThanEq
public :: check_bounds

contains

subroutine dummy_compare()
    !> Dummy routine for module so f2py works.
end subroutine dummy_compare

function EqualTo(a, b, abs_tol) result(equal_to)
    !> Check if two floats are almost equal.
    !> a - First float.
    !> b - Other float.
    !> abs_tol - Absolute toleranace.

    ! Input
    double precision, intent(in) :: a, b
    double precision, intent(in), optional :: abs_tol

    ! Output
    logical :: equal_to

    ! Working
    double precision :: atol, diff

    ! In case they are exact.
    if (a .eq. b) then
        equal_to = .true.
        return
    end if

    ! Set defaults.
    atol = 1.0d-8
    if (present(abs_tol)) then
        atol = abs_tol
    end if

    diff = dabs(b - a)
    ! Absolute comparison.
    if (diff .le. atol) then
        equal_to = .true.
        return
    end if
    equal_to = .false.
end function EqualTo

function GreaterThan(a, b, abs_tol) result(greater_than)
    !> Check if float is almost greater than other.
    !> a - First float.
    !> b - Other float.
    !> abs_tol - Absolute toleranace.

    ! Input
    double precision, intent(in) :: a, b
    double precision, intent(in), optional :: abs_tol

    ! Output
    logical :: greater_than

    ! Working
    double precision :: atol, diff

    ! Set defaults.
    atol = 1.0d-8
    if (present(abs_tol)) then
        atol = abs_tol
    end if

    ! Check almost equal first.
    if (EqualTo(a, b, atol)) then
        greater_than = .false.
        return
    end if
    if (a .gt. b) then
        greater_than = .true.
    else
        greater_than = .false.
    end if
end function GreaterThan

function LessThan(a, b, abs_tol) result(less_than)
    !> Check if float is almost less than other.
    !> a - First float.
    !> b - Other float.
    !> abs_tol - Absolute toleranace.

    ! Input
    double precision, intent(in) :: a, b
    double precision, intent(in), optional :: abs_tol

    ! Output
    logical :: less_than

    ! Working
    double precision :: atol, diff

    ! Set defaults.
    atol = 1.0d-8
    if (present(abs_tol)) then
        atol = abs_tol
    end if

    ! Check almost equal first.
    if (EqualTo(a, b, atol)) then
        less_than = .false.
        return
    end if
    if (a .lt. b) then
        less_than = .true.
    else
        less_than = .false.
    end if
end function LessThan

function GreaterThanEq(a, b, abs_tol) result(greater_than_eq)
    !> Check if float is almost greater than or almost equal to other.
    !> a - First float.
    !> b - Other float.
    !> rel_tol - Relative tolerance.
    !> abs_tol - Absolute toleranace.

    ! Input
    double precision, intent(in) :: a, b
    double precision, intent(in), optional :: abs_tol

    ! Output
    logical :: greater_than_eq

    ! Working
    double precision :: atol, diff

    ! Set defaults.
    atol = 1.0d-8
    if (present(abs_tol)) then
        atol = abs_tol
    end if

    ! Check almost equal first.
    if (EqualTo(a, b, atol)) then
        greater_than_eq = .true.
        return
    end if
    if (a .gt. b) then
        greater_than_eq = .true.
    else
        greater_than_eq = .false.
    end if
end function GreaterThanEq

function LessThanEq(a, b, abs_tol) result(less_than_eq)
    !> Check if float is almost less than or equal to other.
    !> a - First float.
    !> b - Other float.
    !> abs_tol - Absolute toleranace.

    ! Input
    double precision, intent(in) :: a, b
    double precision, intent(in), optional :: abs_tol

    ! Output
    logical :: less_than_eq

    ! Working
    double precision :: atol, diff

    ! Set defaults.
    atol = 1.0d-8
    if (present(abs_tol)) then
        atol = abs_tol
    end if

    ! Check almost equal first.
    if (EqualTo(a, b, atol)) then
        less_than_eq = .true.
        return
    end if
    if (a .lt. b) then
        less_than_eq = .true.
    else
        less_than_eq = .false.
    end if
end function LessThanEq

function check_bounds(x, a, b) result(xout)
    !> Check that a float is between the bounds and return an updated value
    !> if not.
    !> x - Float to check.
    !> a - Lower bound.
    !> b - Upper bound.

    ! Input
    double precision, intent(in) :: x, a, b

    ! Output
    double precision :: xout

    xout = x

    if ( x .lt. a) then
        xout = a
        return
    end if

    if ( x .gt. b) then
        xout = b
        return
    end if

end function check_bounds

end module compare


module constants

    integer, parameter :: V_CYCLE_TYPE = 1
    integer, parameter :: FMG_CYCLE_TYPE = 2
    integer, parameter :: CONST_INTERP = 1
    integer, parameter :: LIN_INTERP = 2
    integer, parameter :: SIN_RHS = 1
    integer, parameter :: RAND_RHS = 2
    integer, parameter :: DELTA_RHS = 3
    integer, parameter :: CONST_COEFFS = 1
    integer, parameter :: RAND_COEFFS = 2

    double precision, parameter :: L = 1.d0
    double precision, parameter :: pi = 4.d0*datan(1.d0)

end module constants


c=======================================================================
c
c     BFGSBOXS
c
c     Quasi-Newton optimizer with BFGS method.
c
c     min f(x) subject to: binf <= x <= bsup
c
c-----------------------------------------------------------------------
      SUBROUTINE bfgsboxs ( simul, simext, nvar, xvar, epsbfg,
     &                      binf, bsup, iwork, dwork,
     &                      xopt, funct, grad, totitr, totsim, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            SIMUL  : entry point of objective function and gradient
c            SIMEXT : entry point of external subroutine
c            nvar   : number of variables                        integer
c            xvar   : initial value of the variables (nvar)       double
c            epsbfg : precision stop test                         double
c            binf   : inferior bounds (nvar)                      double
c            bsup   : superior bounds (nvar)                      double
c
c
c     WORKSPACE
c            iwork  : 2*nvar+1 + space for SIMUL                 integer
c            dwork  : nvar*(nvar+11)/2 + space for SIMUL          double
c
c     OUTPUT
c            xopt   : optimal value(s) at the minimum (nvar)      double
c            funct  : objective function at the minimum           double
c            grad   : gradients value(s) at the minimum (nvar)    double
c            totitr : number of iterations                       integer
c            totsim : number of calls of SIMUL                   integer
c            info   : diagnostic argument                        integer
c
c     CALL
c            SIMUL   : subroutine who computes the function and gradient
c            QNBFGS  : quasi-Newton optimizer with BFGS method (optim)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      EXTERNAL simul, simext
c
c     i/o arguments
      INTEGER nvar, totitr, totsim, info
      DOUBLE PRECISION epsbfg, funct
      DOUBLE PRECISION xvar(*), binf(*), bsup(*), grad(*), xopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER imp, ion2qn, indic, minmax, mode, i, pdxmin, piwb, pdwb,
     &        piws, pdws
      REAL*4 rzs(1)
      DOUBLE PRECISION df1, epsabs, epsdxm, normg, normin
      PARAMETER ( minmax=300, normin=1.d-6, epsdxm=1.d-10 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info   = 0
      imp    = 0
      ion2qn = 6
      indic  = 4
      info   = 0
      mode   = 1
      totitr =  max(minmax, 2*nvar)
      totsim = totitr*3
c
c     pointers for integer workspace : iwork
c     --------------------------------------
      piwb = 1
c     piwb : pointer for n2qn1 who needs (2*nvar + 1)
c             so (2*nvar + 1) more
      piws = piwb + ( 2*nvar + 1 )
c     piws : pointer for SIMUL
c
c     pointers for double precision  workspace : dwork
c     ------------------------------------------------
      pdxmin = 1
c     pdxmin : pointer for dxmin, so (nvar) more
      pdwb = pdxmin + nvar
c     pdwb : pointer for n2qn1 who needs (nvar*(nvar+9)/2)
c             so (nvar*(nvar+9)/2) more
      pdws = pdwb +  nvar*(nvar+9)/2
c     pdws : pointer for SIMUL
c
c-----------------------------------------------------------------------
c
c     first call to initialize function and gradient values
      CALL simul ( indic, simext, nvar, xvar, funct, grad,
     &             iwork(piws), dwork(pdws) )
c
c     computing the precision stop criter
c     ( when mean of projecting gradient < epsabs )
      epsabs = epsbfg * nvar
c      epsabs = epsbfg * sqrt(float(nvar))
c      epsabs = epsbfg
c
c     computing df1 : estimation of the criter decrease
c                     at the first iteration
c                     must be nearly abs( f(xvar)-f(xopt) ) )
      df1 = abs(funct) / 10.
c
c     computing the precision on variables stop criter
      DO i=1,nvar
         normg = max(abs(grad(i)), normin)
         dwork(pdxmin+i-1) = ( df1* epsdxm ) / normg
         xopt(i) = xvar(i)
c         dwork(pdxmin+i-1) = ( df1* epsbfg ) / normg
c         dwork(pdxmin+i-1) = ( df1* epsabs ) / normg
c         dwork(pdxmin+i-1) = sqrt (( df1* epsdxm ) / normg)
      ENDDO
c
c     non linear optimization - BFGS Solver
       CALL qnbfgs ( simul, simext, nvar, xopt,
     &             funct, grad, dwork(pdxmin), df1, epsabs,
     &             imp, ion2qn ,mode, totitr, totsim, binf, bsup,
     &             iwork(piwb), dwork(pdwb),
     &             iwork(piws), rzs, dwork(pdws) )
c
c     error codes
      IF (mode.le.0) info = -1101
      IF (mode.eq.1) info = 0
      IF (mode.eq.2) info = -1102
      IF (mode.eq.3) info = -1103
      IF (mode.eq.4) info =  1104
      IF (mode.eq.5) info =  1105
      IF (mode.eq.6) info =  1106
      IF (mode.eq.7) info = -1107
c
      RETURN
      END


c =========================================================
      subroutine rpt2(ixy,maxm,meqn,mwaves,mbc,
     &      mx,ql,qr,aux1,aux2, aux3, ilr,
     &      asdq, bmasdq, bpasdq)
c =========================================================
c
c     # solve Riemann problems for the 1D Euler equations using Roe's
c     # approximate Riemann solver.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c     # On output, wave contains the waves,
c     #      the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routine step1, rp is called with ql = qr = q.
c
c
      implicit none

      integer maxm, meqn, mwaves, mbc, mx, ilr, ixy
      double precision    ql(1-mbc:maxm+mbc, meqn)
      double precision    qr(1-mbc:maxm+mbc, meqn)
      double precision     s(1-mbc:maxm+mbc, mwaves)
      double precision  wave(1-mbc:maxm+mbc, meqn, mwaves)
      double precision  asdq(1-mbc:maxm+mbc, meqn)
      double precision  bmasdq(1-mbc:maxm+mbc, meqn)
      double precision  bpasdq(1-mbc:maxm+mbc, meqn)
      double precision  aux1(1-mbc:maxm+mbc,*)
      double precision  aux2(1-mbc:maxm+mbc,*)
      double precision  aux3(1-mbc:maxm+mbc,*)

c     # For Roe solver
      double precision rhol, ul, vl, el, cl, pl
      double precision rhor, ur, vr, er, cr, pr
      double precision u, v, enth, rho, p, e
      double precision rhsqrtl, rhsqrtr, rhsq2
      double precision uvl, uvr, uv(2)

c     # For mappings
      integer meqn2,mwaves2
      parameter(meqn2 = 4, mwaves2 = 3)
      double precision ql_state(meqn2), qr_state(meqn2)
      double precision q_state(meqn2)
      double precision wave_local(meqn2,mwaves2)
      double precision s_local(mwaves2), delta(meqn2)
      double precision speeds(mwaves2,2)
      double precision deltam(meqn2), deltap(meqn2)
      double precision area

c     # for mapping
      double precision rotm(4), rotp(4), uvm_rot(2),uvp_rot(2)
      integer locrot,mcapa,locarea

c     # Miscellaneous
      integer i, j, m, mw, i1, ixy1

c     # Problem parameters
      double precision gamma, gamma1

      double precision dtcom, dxcom, dycom, tcom
      integer icom, jcom

      common /param/  gamma,gamma1
      common /comxyt/ dtcom,dxcom,dycom,tcom,icom,jcom

      call get_aux_locations_t(ixy, mcapa, locrot,locarea)

      do i = 2-mbc,mx+mbc
         i1 = i + ilr - 2

c          do m = 1,meqn
c             ql_state(m) = qr(i-1,m)
c             qr_state(m) = ql(i,m)
c          enddo
c
c          rhol = ql_state(1)
c          rhor = qr_state(1)
c
c          ul = ql_state(2)/rhol
c          ur = qr_state(2)/rhor
c
c          vl = ql_state(3)/rhol
c          vr = qr_state(3)/rhor
c
c          el = ql_state(4)
c          er = qr_state(4)
c
c          uvl = ul*ul + vl*vl
c          uvr = ur*ur + vr*vr
c          pl = gamma1*(el - 0.5d0*rhol*uvl)
c          pr = gamma1*(er - 0.5d0*rhor*uvr)
c
c c        # Get Roe averaged values
c          rhsqrtl = sqrt(rhol)
c          rhsqrtr = sqrt(rhor)
c          rhsq2 = rhsqrtl + rhsqrtr

c         uv(1) = (ul*rhsqrtl + ur*rhsqrtr) / rhsq2
c         uv(2) = (vl*rhsqrtl + vr*rhsqrtr) / rhsq2
c         enth = ((el + pl)/rhsqrtl + (er + pr)/rhsqrtr)/rhsq2

         do m = 1,meqn
            if (ilr .eq. 1) then
               q_state(m) = ql(i,m)
            else
               q_state(m) = qr(i-1,m)
            endif
         enddo

         rho = q_state(1)
         uv(1) = q_state(2)/rho
         uv(2) = q_state(3)/rho
         e = q_state(4)
         p = gamma1*(e - 0.5d0*rho*(uv(1)**2 + uv(2)**2))
         enth = (e + p)/rho

         do j = 1,2
            uvm_rot(j) = uv(j)
            uvp_rot(j) = uv(j)
            rotm(j) = aux2(i1,locrot+j-1)
            rotp(j) = aux3(i1,locrot+j-1)
         enddo
         call compute_tangent(rotm)
         call compute_tangent(rotp)

         call rotate2(rotm,uvm_rot)
         call rotate2(rotp,uvp_rot)

c        # Now we have to fix up asdq(i,5) :
         do m = 1,meqn
            deltap(m) = asdq(i,m)
            deltam(m) = asdq(i,m)
         enddo
         call rotate2(rotm,deltam(2))
         call rotate2(rotp,deltap(2))

c        # ------------------------------------------
c        # Solve for minus side
c        # ------------------------------------------
         ixy1 = 1
         call roe_solver(ixy1,uvm_rot,enth,deltam,
     &         wave_local,s_local)

         area = aux2(i1,locarea)
         do mw = 1,mwaves
            call rotate2_tr(rotm,wave_local(2,mw))
            speeds(mw,1) = area*min(s_local(mw),0.d0)
         enddo

         do m = 1,meqn
            bmasdq(i,m) = 0.d0
            do mw = 1,mwaves
               bmasdq(i,m) = bmasdq(i,m) + speeds(mw,1)*wave_local(m,mw)
            enddo
         enddo

c        # ------------------------------------------
c        # Solve for plus side
c        # ------------------------------------------
         ixy1 = 1
         call roe_solver(ixy1,uvp_rot,enth,deltap,
     &         wave_local,s_local)

         area = aux3(i1,locarea)
         do mw = 1,mwaves
            call rotate2_tr(rotp,wave_local(2,mw))
            speeds(mw,2) = area*max(s_local(mw),0.d0)
         enddo

         do m = 1,meqn
            bpasdq(i,m) = 0.d0
            do mw = 1,mwaves
               bpasdq(i,m) = bpasdq(i,m) + speeds(mw,2)*wave_local(m,mw)
            enddo
         enddo

      enddo !! end of i loop

      return
      end