C$Procedure      INELPL ( Intersection of ellipse and plane )

      SUBROUTINE INELPL ( ELLIPS, PLANE, NXPTS, XPT1, XPT2 )

C$ Abstract
C
C     Find the intersection of an ellipse and a plane.
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     PLANES
C
C$ Keywords
C
C     ELLIPSE
C     GEOMETRY
C     MATH
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL = 9 )

      INTEGER               UBPL
      PARAMETER           ( UBPL = 4 )

      DOUBLE PRECISION      ELLIPS ( UBEL )
      DOUBLE PRECISION      PLANE  ( UBPL )
      INTEGER               NXPTS
      DOUBLE PRECISION      XPT1   ( 3 )
      DOUBLE PRECISION      XPT2   ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ELLIPS     I   A SPICELIB ellipse.
C     PLANE      I   A SPICELIB plane.
C     NXPTS      O   Number of intersection points of plane and ellipse.
C     XPT1,
C     XPT2       O   Intersection points.
C
C$ Detailed_Input
C
C     ELLIPS         is a SPICELIB ellipse. The ellipse is allowed to
C                    be degenerate: one or both semi-axes may have
C                    zero length.
C
C     PLANE          is a SPICELIB plane.
C
C$ Detailed_Output
C
C     NXPTS          is the number of points of intersection of the
C                    geometric plane and ellipse represented by PLANE
C                    and ELLIPS. NXPTS may take the values 0, 1, 2 or
C                    -1.  The value -1 indicates that the ellipse
C                    consists of more than one point and lies in the
C                    plane, so the number of intersection points is
C                    infinite.
C
C                    When the ellipse consists of a single point and
C                    lies in the plane, NXPTS is set to 1.
C
C     XPT1,
C     XPT2           are the points of intersection of the input plane
C                    and ellipse. If there is only one intersection
C                    point, both XPT1 and XPT2 contain that point. If
C                    the number of intersection points is zero or
C                    infinite, the contents of XPT1 and XPT2 are
C                    undefined.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  The input plane must be a SPICE plane: the normal vector must
C         be non-zero and the constant must be non-negative.
C         If the input plane is invalid, the error SPICE(INVALIDPLANE)
C         will be signaled.
C
C     2)  If the input ellipse has non-orthogonal axes, the error
C         SPICE(INVALIDELLIPSE) will be signaled.
C
C     3)  The input ellipse is allowed to be a line segment or a point;
C         these cases are not considered to be errors. If the ellipse
C         consists of a single point and lies in the plane, the number
C         of intersection points is set to 1 (rather than -1) and
C         the output arguments XPT1 and XPT2 are assigned the value
C         of the ellipse's center.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine computes the intersection set of a non-degenerate
C     plane with a possibly degenerate ellipse. The ellipse is allowed
C     to consist of a line segment or a point.
C
C     A plane may intersect an ellipse in 0, 1, 2, or infinitely many
C     points. For there to be an infinite set of intersection points,
C     the ellipse must lie in the plane and consist of more than one
C     point.
C
C$ Examples
C
C     1)  If we want to find the angle of some ray above the limb of an
C         ellipsoid, where the angle is measured in a plane containing
C         the ray and a `down' vector, we can follow the procedure
C         given below.  We assume the ray does not intersect the
C         ellipsoid.  The result we seek is called ANGLE, imaginatively
C         enough.
C
C         We assume that all vectors are given in body-fixed
C         coordinates.
C
C            C
C            C     Find the limb of the ellipsoid as seen from the
C            C     point OBSERV.  Here A, B, and C are the lengths of
C            C     the semi-axes of the ellipsoid.
C            C
C                  CALL EDLIMB ( A, B, C, OBSERV, LIMB )
C
C            C
C            C     The ray direction vector is RAYDIR, so the ray is the
C            C     set of points
C            C
C            C        OBSERV  +  t * RAYDIR
C            C
C            C     where t is any non-negative real number.
C            C
C            C     The `down' vector is just -OBSERV.  The vectors
C            C     OBSERV and RAYDIR are spanning vectors for the plane
C            C     we're interested in.  We can use PSV2PL to represent
C            C     this plane by a SPICELIB plane.
C            C
C                  CALL PSV2PL ( OBSERV, OBSERV, RAYDIR, PLANE )
C
C            C
C            C     Find the intersection of the plane defined by OBSERV
C            C     and RAYDIR with the limb.
C            C
C                  CALL INELPL ( LIMB, PLANE, NXPTS, XPT1, XPT2 )
C
C            C
C            C     We always expect two intersection points, if DOWN
C            C     is valid.
C            C
C                  IF ( NXPTS .LT. 2 ) THEN
C
C                     [ do something about the error ]
C
C                  ENDIF
C
C            C
C            C     Form the vectors from OBSERV to the intersection
C            C     points.  Find the angular separation between the
C            C     boresight ray and each vector from OBSERV to the
C            C     intersection points.
C            C
C                  CALL VSUB   ( XPT1, OBSERV, VEC1 )
C                  CALL VSUB   ( XPT2, OBSERV, VEC2 )
C
C                  SEP1 = VSEP ( VEC1, RAYDIR )
C                  SEP2 = VSEP ( VEC2, RAYDIR )
C
C            C
C            C     The angular separation we're after is the minimum of
C            C     the two separations we've computed.
C            C
C                  ANGLE = MIN ( SEP1, SEP2 )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.0.0, 07-OCT-2011 (NJB)
C
C        Relaxed ellipse semi-axes orthogonality test limit
C        SEPLIM from 1.D-12 TO 1.D-9 radians. The angular
C        separation of the axes of the input ellipse must not
C        differ from pi/2 radians by more than this limit.
C
C-    SPICELIB Version 2.0.0, 14-JAN-2008 (NJB)
C
C        Bug fix: the routine's specification and behavior have been
C        updated so the routine now returns a meaningful result for the
C        case of an ellipse consisting of a single point.
C
C        Bug fix: in the degenerate case where the input ellipse is a
C        line segment of positive length, and this segment intersects
C        the plane, the number of intersection points is set to 1
C        rather than 2.
C
C        Invalid input planes and ellipses are now diagnosed.
C
C-    SPICELIB Version 1.2.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSUB call.
C
C-    SPICELIB Version 1.1.0, 24-MAR-1992 (NJB) (WLT)
C
C        Output arguments XPT1, XPT2 are now correctly declared
C        with length 3.  Comment section for permuted index source
C        lines was added following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     intersection of ellipse and plane
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.0.0, 14-JAN-2008 (NJB)
C
C        Bug fix: the routine's specification and behavior have been
C        updated so the routine now returns a meaningful result for the
C        case of an ellipse consisting of a single point. In this case,
C        if an intersection is found, the number of intersection points
C        is set to 1 and both intersection arguments are set equal to
C        the ellipse's center.
C
C        Bug fix: in the degenerate case where the input ellipse is a
C        line segment of positive length, and this segment intersects
C        the plane, the number of intersection points is set to 1
C        rather than 2.
C
C        Invalid input planes and ellipses are now diagnosed.
C        Error handling code has been added to trap errors that had
C        been erroneously passed off to lower level routines for
C        diagnosis.
C
C-    SPICELIB Version 1.2.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSUB call.
C
C-    SPICELIB Version 1.1.0, 24-MAR-1992 (NJB) (WLT)
C
C        Output arguments XPT1, XPT2 are now correctly declared
C        with length 3.  They formerly were declared as scalars.
C        The correction will not affect the behavior of the routine
C        in programs that already declared the correponding arguments
C        correctly.
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      HALFPI
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORMG
      DOUBLE PRECISION      VSEP

      LOGICAL               RETURN
      LOGICAL               VZERO
      LOGICAL               VZEROG

C
C     Local parameters
C
      DOUBLE PRECISION      SEPLIM
      PARAMETER           ( SEPLIM = 1.D-9 )

C
C     Local variables
C
      DOUBLE PRECISION      ALPHA
      DOUBLE PRECISION      ANGLE1
      DOUBLE PRECISION      ANGLE2
      DOUBLE PRECISION      BETA
      DOUBLE PRECISION      CENTER (    3 )
      DOUBLE PRECISION      CONST
      DOUBLE PRECISION      INPCON
      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      POINT  (    3 )
      DOUBLE PRECISION      SEP
      DOUBLE PRECISION      SMAJOR (    3 )
      DOUBLE PRECISION      SMINOR (    3 )
      DOUBLE PRECISION      TMPVEC (    3 )
      DOUBLE PRECISION      TRANS  ( UBPL )
      DOUBLE PRECISION      V      (    2 )

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

      CALL CHKIN ( 'INELPL' )

C
C     Check the input plane.
C
      CALL PL2NVC ( PLANE, NORMAL, INPCON )

      IF ( VZERO(NORMAL) ) THEN

         CALL SETMSG ( 'Input SPICE plane has zero normal vector.' )
         CALL SIGERR ( 'SPICE(INVALIDPLANE)'                       )
         CALL CHKOUT ( 'INELPL'                                    )
         RETURN

      ELSE IF ( INPCON .LT. 0.D0 ) THEN

         CALL SETMSG ( 'Input SPICE plane has non-positive '
     .   //            'constant #. Properly constructed '
     .   //            'SPICE planes always have non-negative '
     .   //            'constants.'                                )
         CALL ERRDP  ( '#',  INPCON                                )
         CALL SIGERR ( 'SPICE(INVALIDPLANE)'                       )
         CALL CHKOUT ( 'INELPL'                                    )
         RETURN

      END IF

C
C     Get the components of the input ellipse; check for
C     invalid semi-axes. The semi-axes may have zero length
C     but they must always be orthogonal. We require this
C     check only if both semi-axes have non-zero length.
C
      CALL EL2CGV ( ELLIPS, CENTER, SMAJOR, SMINOR )

      IF ( .NOT. VZERO(SMINOR) ) THEN

         SEP = VSEP( SMAJOR, SMINOR )

         IF (  ABS( SEP - HALFPI() )  .GT.  SEPLIM  ) THEN

            CALL SETMSG ( 'Input SPICE ellipse has non-orthogonal '
     .      //            'semi-axes: (#,#,#) and (#,#,#). Angular '
     .      //            'separation of these vectors is # radians. '
     .      //            'Properly constructed SPICE ellipses '
     .      //            'always have orthogonal semi-axes.'         )
            CALL ERRDP  ( '#',  SMAJOR(1)                             )
            CALL ERRDP  ( '#',  SMAJOR(2)                             )
            CALL ERRDP  ( '#',  SMAJOR(3)                             )
            CALL ERRDP  ( '#',  SMINOR(1)                             )
            CALL ERRDP  ( '#',  SMINOR(2)                             )
            CALL ERRDP  ( '#',  SMINOR(3)                             )
            CALL ERRDP  ( '#',  SEP                                   )
            CALL SIGERR ( 'SPICE(INVALIDELLIPSE)'                     )
            CALL CHKOUT ( 'INELPL'                                    )
            RETURN

         END IF

      END IF

C
C     If the input ellipse is a single point, decide now
C     whether the ellipse lies in the plane.
C
      IF ( VZERO(SMAJOR) ) THEN
C
C        The ellipse is a single point. If the ellipse's center
C        lies in the plane, the whole ellipse is the one
C        intersection point. Check the inner product of the
C        center and the plane's normal vector.
C
         IF (  VDOT( CENTER, NORMAL )  .EQ.  INPCON  ) THEN
C
C           The center does in fact lie in the plane.
C
            NXPTS = 1

            CALL VEQU ( CENTER, XPT1 )
            CALL VEQU ( CENTER, XPT2 )

         ELSE
C
C           There's no intersection: the intersection arguments
C           are left undefined in this case.
C
            NXPTS = 0

         END IF

C
C        Return now; this simplifies the logic to follow.
C
         CALL CHKOUT ( 'INELPL' )
         RETURN

      END IF

C
C     At this point the ellipse may still be degenerate: it can be a
C     line segment. We'll need to compute the intersection point or
C     points if we have a positive, finite intersection set.
C
C     The first thing we want to do is translate the plane and the
C     ellipse so as to center the ellipse at the origin.  To translate
C     the plane, just get a point and normal vector, and translate
C     the point.  Find the plane constant of the translated plane.
C
      CALL PL2NVP ( PLANE,   NORMAL,  TMPVEC )
      CALL VSUB   ( TMPVEC,  CENTER,  POINT  )
      CALL NVP2PL ( NORMAL,  POINT,   TRANS  )

      CALL PL2NVC ( TRANS,   NORMAL,  CONST  )

C
C     Ok, we can get to work.  The locus of the ellipse is
C
C        cos(theta) SMAJOR  +  sin(theta) SMINOR,
C
C     and any point X of the ellipse that intersects the input plane
C     satisfies
C
C        < X, NORMAL >  =  CONST.
C
C     Substituting our expression for points on the ellipse into the
C     second equation, we arrive at
C
C           cos(theta) < SMAJOR, NORMAL >
C        +  sin(theta) < SMINOR, NORMAL >   =  CONST.        (1)
C
C     This equation merits a little analysis. First, if NORMAL
C     is orthogonal to SMAJOR and SMINOR, the plane and ellipse must
C     be parallel. Also, the left side of the equation is zero in
C     this case. If CONST is non-zero, there are no solutions:
C     the ellipse and plane are parallel but do not intersect. If
C     CONST is zero, the ellipse lies in the plane: all values of
C     theta are solutions. Let's get this case out of the way
C     right now, shall we?
C
      V(1) = VDOT ( SMAJOR, NORMAL )
      V(2) = VDOT ( SMINOR, NORMAL )

C
C     Test whether the plane and ellipse are parallel:
C
      IF (  VZEROG( V, 2 )  ) THEN
C
C        The ellipse lies in the plane if and only if CONST is zero.
C        In any case, we don't modify XPT1 or XPT2.
C
         IF ( CONST .EQ. 0.D0 ) THEN
            NXPTS = -1
         ELSE
            NXPTS = 0
         END IF

         CALL CHKOUT ( 'INELPL' )
         RETURN

      END IF

C
C     Now if NORMAL is not orthogonal to both SMAJOR and SMINOR,
C     the vector
C
C        V = (  < SMAJOR, NORMAL >,  < SMINOR, NORMAL >  )
C
C     is non-zero.  We can re-write (1) as
C
C        < U, V >  =  CONST,
C
C     where
C
C        U = ( cos(theta), sin(theta) ).
C
C     If alpha is the angle between U and V, we have
C
C        < U, V >  =  || U ||  *  || V ||  *  cos(alpha),
C
C     so
C
C        || V ||  *  cos(alpha)  =  CONST.                   (2)
C
C     CONST is positive, since PL2NVC returns the distance
C     of between its input plane and the origin as the output
C     plane constant.
C
C     Equation (2) has solutions if and only if
C
C        || V ||  >    CONST.                                (3)
C                 -
C
C     Let's return right now if there are no solutions.
C
      IF (  VNORMG( V, 2 )  .LT.  CONST  )   THEN

         NXPTS = 0
         CALL CHKOUT ( 'INELPL' )
         RETURN

      END IF

C
C     Since (3) above is satisfied, the plane and ellipse intersect.
C     We can find alpha using the formula
C
C        alpha  =  +  arccos (  CONST  /  || V ||  )
C
C     Since alpha is the angular separation between U and V, we
C     can find U once we have the angular position of V; let's
C     call that beta.  The angular position of U (which we called
C     theta earlier) will be
C
C        theta   =   beta  +  alpha.
C                          -
C
C     The values of theta are the angles we seek.
C

      ALPHA   =  ACOS  (  CONST  /  VNORMG ( V, 2 )  )

      BETA    =  ATAN2 ( V(2), V(1) )

      ANGLE1  =  BETA - ALPHA
      ANGLE2  =  BETA + ALPHA

C
C     Determine the number of intersection points. We have a special
C     case if the semi-minor axis has length zero: in that case BETA is
C     zero or Pi, and although ANGLE1 and ANGLE2 may differ, the
C     cosines of these angles are identical. Since in this case
C     the solutions corresponding to ANGLE1 and ANGLE2 have the
C     form
C
C        CENTER + cos(ANGLE1)*SMAJOR
C        CENTER + cos(ANGLE2)*SMAJOR
C
C     the solutions are identical.
C
C
      IF ( VZERO(SMINOR) ) THEN

         NXPTS = 1

      ELSE

         IF ( ANGLE1 .EQ. ANGLE2 ) THEN
C
C           This case occurs when ALPHA is zero.
C
            NXPTS = 1
         ELSE
            NXPTS = 2
         END IF

      END IF

C
C     Compute the intersection points.
C
      CALL VLCOM3 ( 1.0D0,         CENTER,
     .              DCOS(ANGLE1),  SMAJOR,
     .              DSIN(ANGLE1),  SMINOR,    XPT1 )

      CALL VLCOM3 ( 1.0D0,         CENTER,
     .              DCOS(ANGLE2),  SMAJOR,
     .              DSIN(ANGLE2),  SMINOR,    XPT2 )

      CALL CHKOUT ( 'INELPL' )
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program 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 General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine straighteq3d(col,straight)
!
!     calculate the equation of the planes through the
!     edges of a triangle and perpendicular to the triangle together
!     with the plane of the triangle itself with
!     (col(1,1),col(2,1),col(3,1)),(col(1,2),col(2,2),col(3,2)),
!     (col(1,3),col(2,3),col(3,3))
!     as vertices. The equation of the plane through the edge
!     opposite nodet(1) is of the form
!     straight(1)*x+straight(2)*y+straight(3)*z+straight(4)=0, such that the
!     vector (straight(1),straight(2),straight(3)) points outwards;
!     for the edge opposite of nodet(2) the equation is
!     straight(5)*x+straight(6)*y+straight(7)*z+straight(8)=0 and for the edge
!     oppositie of nodet(3) it is
!     straight(9)*x+straight(10)*y+straight(11)*z+straight(12)=0.
!     Here too, the normals
!     (straight(5),straight(6),straight(7)) and
!     (straight(9),straight(10),straight(11)) point
!     outwards of the triangle. The equation of the triangle plane is
!     straight(13)*x+straight(14)*y+straight(15)*z+straight(16)=0 such
!     that the triangle is numbered clockwise when looking in the
!     direction of vector (straight(13),straight(14),straight(15)).
!
      implicit none
!
      integer i
!
      real*8 col(3,3),straight(16),p12(3),p23(3),p31(3),dd
!
!
!
!     sides of the triangle
!
      do i=1,3
         p12(i)=col(i,2)-col(i,1)
         p23(i)=col(i,3)-col(i,2)
         p31(i)=col(i,1)-col(i,3)
      enddo
!
!     normalized vector normal to the triangle: xn = p12 x p23
!
      straight(13)=p12(2)*p23(3)-p12(3)*p23(2)
      straight(14)=p12(3)*p23(1)-p12(1)*p23(3)
      straight(15)=p12(1)*p23(2)-p12(2)*p23(1)
      dd=dsqrt(straight(13)*straight(13)+straight(14)*straight(14)+
     &         straight(15)*straight(15))
      do i=13,15
         straight(i)=straight(i)/dd
      enddo
!
!     p12 x xn
!
      straight(9)=p12(2)*straight(15)-p12(3)*straight(14)
      straight(10)=p12(3)*straight(13)-p12(1)*straight(15)
      straight(11)=p12(1)*straight(14)-p12(2)*straight(13)
      dd=dsqrt(straight(9)*straight(9)+straight(10)*straight(10)+
     &         straight(11)*straight(11))
      do i=9,11
         straight(i)=straight(i)/dd
      enddo
!
!     p23 x xn
!
      straight(1)=p23(2)*straight(15)-p23(3)*straight(14)
      straight(2)=p23(3)*straight(13)-p23(1)*straight(15)
      straight(3)=p23(1)*straight(14)-p23(2)*straight(13)
      dd=dsqrt(straight(1)*straight(1)+straight(2)*straight(2)+
     &         straight(3)*straight(3))
      do i=1,3
         straight(i)=straight(i)/dd
      enddo
!
!     p31 x xn
!
      straight(5)=p31(2)*straight(15)-p31(3)*straight(14)
      straight(6)=p31(3)*straight(13)-p31(1)*straight(15)
      straight(7)=p31(1)*straight(14)-p31(2)*straight(13)
      dd=dsqrt(straight(5)*straight(5)+straight(6)*straight(6)+
     &         straight(7)*straight(7))
      do i=5,7
         straight(i)=straight(i)/dd
      enddo
!
!     determining the inhomogeneous terms
!
      straight(12)=-straight(9)*col(1,1)-straight(10)*col(2,1)-
     &             straight(11)*col(3,1)
      straight(4)=-straight(1)*col(1,2)-straight(2)*col(2,2)-
     &             straight(3)*col(3,2)
      straight(8)=-straight(5)*col(1,3)-straight(6)*col(2,3)-
     &             straight(7)*col(3,3)
      straight(16)=-straight(13)*col(1,1)-straight(14)*col(2,1)-
     &             straight(15)*col(3,1)
!
      return
      end


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver.
!> Copyright (C) Butakov Oleg 2019.

Module orchid_solver_hydro_jacobian
Use orchid_solver_params
Use orchid_solver_hydro_var
Implicit None
Type :: MhdHydroJacobian1D
    Real(8), Dimension(1:3) :: Lambda
    Real(8), Dimension(1:3, 1:3) :: OmegaL, OmegaR
End Type MhdHydroJacobian1D
Type :: MhdHydroJacobian2D
    Real(8), Dimension(1:4) :: Lambda
    Real(8), Dimension(1:4, 1:4) :: OmegaL, OmegaR
End Type MhdHydroJacobian2D
Type :: MhdHydroJacobian3D
    Real(8), Dimension(1:5) :: Lambda
    Real(8), Dimension(1:5, 1:5) :: OmegaL, OmegaR
End Type MhdHydroJacobian3D
Type :: MhdHydroJacobian1DMHD
    Real(8), Dimension(1:7) :: Lambda
    Real(8), Dimension(1:7, 1:7) :: OmegaL, OmegaR
End Type MhdHydroJacobian1DMHD
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_jacobian_load1D(q, J, nx)
    !> Calculate the Euler equations Jacobian decomposision in 1D.
    !> {{{
    Type(MhdHydroVars1D), Intent(In) :: q
    Type(MhdHydroJacobian1D), Intent(Out) :: J
    Real(8), Intent(In) :: nx
    !> }}}
    !> Calculate Eigenvalues.
    J%Lambda(:) = [ q%Vn - q%c_snd, q%Vn, &
                    q%Vn + q%c_snd ]
    !> Calculate the Right Eigenvectors.
    J%OmegaR(:,2) = [ 1.0D0, q%Vx, q%kin ]
    J%OmegaR(:,1) = [ 1.0D0, q%Vx - q%c_snd*nx, &
                             q%ent - q%c_snd*q%Vn ]
    J%OmegaR(:,3) = [ 1.0D0, q%Vx + q%c_snd*nx, &
                             q%ent + q%c_snd*q%Vn ]
    !> Calculate the Left Eigenvectors.
    J%OmegaL(2,:) = [ -Gamma1*q%kin + q%c2snd, &
                      +Gamma1*q%Vx, &
                      -Gamma1 ]/q%c2snd
    J%OmegaL(1,:) = [ +Gamma1*q%kin + q%c_snd*q%Vn, &
                      -Gamma1*q%Vx  - q%c_snd*nx, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
    J%OmegaL(3,:) = [ +Gamma1*q%kin - q%c_snd*q%Vn, &
                      -Gamma1*q%Vx  + q%c_snd*nx, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
End Subroutine mhd_hydro_jacobian_load1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_jacobian_load2D(q, J, nx, ny)
    !> Calculate the Euler equations Jacobian decomposision in 2D.
    !> {{{
    Type(MhdHydroVars2D), Intent(In) :: q
    Type(MhdHydroJacobian2D), Intent(Out) :: J
    Real(8), Intent(In) :: nx, ny
    !> }}}
    !> Calculate Eigenvalues.
    J%Lambda(:) = [ q%Vn - q%c_snd, q%Vn, &
                    q%Vn + q%c_snd, q%Vn ]
    !> Calculate the Right Eigenvectors.
    J%OmegaR(:,2) = [ 1.0D0, q%Vx, q%Vy, q%kin ]
    J%OmegaR(:,1) = [ 1.0D0, q%Vx - q%c_snd*nx, &
                             q%Vy - q%c_snd*ny, &
                             q%ent - q%c_snd*q%Vn ]
    J%OmegaR(:,3) = [ 1.0D0, q%Vx + q%c_snd*nx, &
                             q%Vy + q%c_snd*ny, &
                             q%ent + q%c_snd*q%Vn ]
    J%OmegaR(:,4) = [ 0.0D0, +ny, -nx, &
                      q%Vx*ny - q%Vy*nx ]
    !> Calculate the Left Eigenvectors.
    J%OmegaL(1,:) = [ +Gamma1*q%kin + q%c_snd*q%Vn, &
                      -Gamma1*q%Vx  - q%c_snd*nx, &
                      -Gamma1*q%Vy  - q%c_snd*ny, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
    J%OmegaL(2,:) = [ -Gamma1*q%kin + q%c2snd, &
                      +Gamma1*q%Vx, &
                      +Gamma1*q%Vy, &
                      -Gamma1 ]/q%c2snd
    J%OmegaL(3,:) = [ +Gamma1*q%kin - q%c_snd*q%Vn, &
                      -Gamma1*q%Vx  + q%c_snd*nx, &
                      -Gamma1*q%Vy  + q%c_snd*ny, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
    J%OmegaL(4,:) = [ q%Vy*nx - q%Vx*ny, &
                      +ny, -nx, 0.0D0 ]
End Subroutine mhd_hydro_jacobian_load2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_jacobian_load3D(q, J, nx, ny, nz)
    !> Calculate the Euler equations Jacobian decomposision in 2D.
    !> {{{
    Type(MhdHydroVars3D), Intent(In) :: q
    Type(MhdHydroJacobian3D), Intent(Out) :: J
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Integer :: dir
    !> Select direction to prevent 0/0 singularities.
    If ( Abs(nx) >= Max(Abs(ny), Abs(nz)) ) Then
        dir = 1
    Else If ( Abs(ny) >= Max(Abs(nx), Abs(nz)) ) Then
        dir = 2
    Else If ( Abs(nz) >= Max(Abs(nx), Abs(ny)) ) Then
        dir = 3
    End If
    !> Calculate Eigenvalues.
    J%Lambda(:) = [ q%Vn - q%c_snd, q%Vn, &
                    q%Vn + q%c_snd, q%Vn, q%Vn ]
    !> Calculate the Right Eigenvectors.
    J%OmegaR(:,2) = [ 1.0D0, q%Vx, q%Vy, q%Vz, q%kin ]
    J%OmegaR(:,1) = [ 1.0D0, q%Vx - q%c_snd*nx, &
                             q%Vy - q%c_snd*ny, &
                             q%Vz - q%c_snd*nz, &
                             q%ent - q%c_snd*q%Vn ]
    J%OmegaR(:,3) = [ 1.0D0, q%Vx + q%c_snd*nx, &
                             q%Vy + q%c_snd*ny, &
                             q%Vz + q%c_snd*nz, &
                             q%ent + q%c_snd*q%Vn ]
    Select Case ( dir )
    Case ( 1 )
        J%OmegaR(:,4) = [ 0.0D0, +ny, -nx, 0.0D0, q%Vx*ny - q%Vy*nx ]
        J%OmegaR(:,5) = [ 0.0D0, -nz, 0.0D0, +nx, q%Vz*nx - q%Vx*nz ]
    Case ( 2 )
        J%OmegaR(:,4) = [ 0.0D0, +ny, -nx, 0.0D0, q%Vx*ny - q%Vy*nx ]
        J%OmegaR(:,5) = [ 0.0D0, 0.0D0, +nz, -ny, q%Vy*nz - q%Vz*ny ]
    Case ( 3 )
        J%OmegaR(:,4) = [ 0.0D0, -nz, 0.0D0, +nx, q%Vz*nx - q%Vx*nz ]
        J%OmegaR(:,5) = [ 0.0D0, 0.0D0, +nz, -ny, q%Vy*nz - q%Vz*ny ]
    End Select
    !> Calculate the Left Eigenvectors.
    J%OmegaL(2,:) = [ -Gamma1*q%kin + q%c2snd, &
                      +Gamma1*q%Vx, +Gamma1*q%Vy, +Gamma1*q%Vz, -Gamma1 ]/q%c2snd
    J%OmegaL(1,:) = [ +Gamma1*q%kin + q%c_snd*q%Vn, &
                      -Gamma1*q%Vx - q%c_snd*nx, &
                      -Gamma1*q%Vy - q%c_snd*ny, &
                      -Gamma1*q%Vz - q%c_snd*nz, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
    J%OmegaL(3,:) = [ +Gamma1*q%kin - q%c_snd*q%Vn, &
                      -Gamma1*q%Vx + q%c_snd*nx, &
                      -Gamma1*q%Vy + q%c_snd*ny, &
                      -Gamma1*q%Vz + q%c_snd*nz, &
                      +Gamma1 ]/( 2.0D0*q%c2snd )
    Select Case ( dir )
    Case ( 1 )
        J%OmegaL(4,:) = [ ( q%Vy - q%Vn*ny )/nx, +ny, ( ny**2 - 1.0D0 )/nx, ( +ny*nz )/nx, 0.0D0 ]
        J%OmegaL(5,:) = [ ( q%Vn*nz - q%Vz )/nx, -nz, ( -ny*nz )/nx, ( 1.0D0 - nz**2 )/nx, 0.0D0 ]
    Case ( 2 )
        !> @todo Fix me!
    Case ( 3 )
        !> @todo Fix me!
    End Select
End Subroutine mhd_hydro_jacobian_load3D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_jacobian_load1D_mhd(q, J)
    !> Calculate the MHD equations Jacobian decomposision in 1D
    !> (in X direction, assuming Bx is const).
    !> {{{
    Type(MhdHydroVars3DMHD), Intent(In) :: q
    Type(MhdHydroJacobian1DMHD), Intent(Out) :: J
    !> }}}
    Real(8) :: sgn, r, t, t2, s
    Real(8) :: Al2fms, Al2sms, &
               Al_fms, Al_sms
    Real(8) :: R_fms, R_sms
    Real(8) :: Bt_y, Bt_z
    Real(8), Parameter :: PO = 1.0D0, MO = -1.0D0, ZZ = 0.0D0
    Real(8), Dimension(1:7) :: su, ss
    Real(8), Dimension(1:7, 1:7) :: UW, WU
    !> Calculate aux variables.
    s = Sqrt(q%By**2 + q%Bz**2)
    Bt_y = q%By/s*2.0D0*Sqrt(Pi)
    Bt_z = q%Bz/s*2.0D0*Sqrt(Pi)
    s = q%c2fms - q%c2sms
    Al2fms = ( q%c2fms - q%c2aln )/s
    Al2sms = ( q%c2fms - q%c2snd )/s
    Al_fms = Sqrt(Al2fms)
    Al_sms = Sqrt(Al2sms)
    R_fms = Al2fms*( q%c2fms + q%c2snd ) + Al2sms*( q%c2fms + q%c2aln )
    R_sms = Al2fms*q%c2snd*( q%c2fms + q%c2snd ) + Al2sms*q%c2fms*( q%c2sms + q%c2snd )
    R_fms = q%c_fms/Sqrt(R_fms)
    R_sms = q%c2fms/Sqrt(R_sms)
    r = Sqrt(4.0D0*Pi*q%Rho)
    sgn = Sign(1.0D0, q%Bx)
    !> Calculate Eigenvalues.
    J%Lambda(:) = [ q%Vx - q%c_fms, q%Vx - q%c_aln, q%Vx - q%c_sms, q%Vx, &
                    q%Vx + q%c_sms, q%Vx + q%c_aln, q%Vx + q%c_fms ]
    !> Calculate the Right Eigenvectors in W.
    t = 1.0D0/q%Rho
    su(:) = [ t, PO, sgn*Bt_y, sgn*Bt_z, r*Bt_y, r*Bt_z, Gamma*q%p ]
    ss(:) = [ Al_fms, Al_fms*q%c_fms, &
              Al_sms*q%c_aln, Al_sms*q%c_aln, &
              Al_sms*q%c_fms, Al_sms*q%c_fms, Al_fms ]*R_fms*su
    J%OmegaR(:,7) = ss(:)*[MO,PO,MO,MO,PO,PO,PO]
    J%OmegaR(:,1) = ss(:)*[PO,PO,MO,MO,MO,MO,MO]
    ss(:) = [ Al_sms, Al_sms*q%c_sms, &
              Al_fms*q%c_snd, Al_fms*q%c_snd, &
              Al_fms*q%c2snd/q%c_fms, Al_fms*q%c2snd/q%c_fms, Al_sms ]*R_sms*su
    J%OmegaR(:,5) = ss(:)*[MO,PO,PO,PO,MO,MO,PO]
    J%OmegaR(:,3) = ss(:)*[PO,PO,PO,PO,PO,PO,MO]
    ss(:) = [ 0.0D0, 0.0D0, &
              Bt_z, Bt_y, sgn*r*Bt_z, sgn*r*Bt_y, 0.0D0 ]*q%c_fms/Sqrt(2.0D0)
    J%OmegaR(:,6) = ss(:)*[ZZ,ZZ,PO,MO,MO,PO,ZZ]
    J%OmegaR(:,2) = ss(:)*[ZZ,ZZ,MO,PO,MO,PO,ZZ]
    J%OmegaR(:,4) = [t,ZZ,ZZ,ZZ,ZZ,ZZ,ZZ]
    !> Calculate the Left Eigenvectors in W.
    su(:) = [ ZZ, PO, sgn*Bt_y, sgn*Bt_z, Bt_y/r, Bt_z/r, PO ]
    ss(:) = [ ZZ, Al_fms*q%c_fms, &
                  Al_sms*q%c_aln, Al_sms*q%c_aln, &
                  Al_sms*q%c_fms, Al_sms*q%c_fms, Al_fms*t ]*R_fms/q%c2fms*su
    J%OmegaL(7,:) = ss(:)*[ZZ,PO,MO,MO,PO,PO,PO]
    J%OmegaL(1,:) = ss(:)*[ZZ,PO,MO,MO,MO,MO,MO]
    ss(:) = [ZZ, Al_sms*q%c_sms, &
                 Al_fms*q%c_snd, Al_fms*q%c_snd, &
                 Al_fms*q%c2snd/q%c_fms, Al_fms*q%c2snd/q%c_fms, Al_sms*Gamma*q%p ]*R_sms/q%c2fms*su
    J%OmegaL(5,:) = ss(:)*[ZZ,PO,PO,PO,MO,MO,PO]
    J%OmegaL(3,:) = ss(:)*[ZZ,PO,PO,PO,PO,PO,MO]
    ss(:) = [ 0.0D0, 0.0D0, &
              Bt_z, Bt_y, sgn/r*Bt_z, sgn/r*Bt_y, 0.0D0 ]/q%c_fms/Sqrt(2.0D0)
    J%OmegaL(6,:) = ss(:)*[ZZ,ZZ,PO,MO,MO,PO,ZZ]
    J%OmegaL(2,:) = ss(:)*[ZZ,ZZ,MO,PO,MO,PO,ZZ]
    J%OmegaL(4,:) = [q%Rho,ZZ,ZZ,ZZ,ZZ,ZZ,1.0D0/Gamma/q%p]
    !> Calculate the dW/dU.
    t = 1.0D0/q%Rho
    t2 = t**2
    WU(1,:) = [ -t2, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    WU(2,:) = [ -t2*q%Vx, t, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    WU(3,:) = [ -t2*q%Vy, 0.0D0, t, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    WU(4,:) = [ -t2*q%Vz, 0.0D0, 0.0D0, t, 0.0D0, 0.0D0, 0.0D0 ]
    WU(5,:) = [ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 1.0D0, 0.0D0, 0.0D0 ]
    WU(6,:) = [ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 1.0D0, 0.0D0 ]
    WU(7,:) = [ +Gamma1*q%V2*0.5D0, &
                -Gamma1*q%Vx, -Gamma1*q%Vy, -Gamma1*q%Vz, &
                -Gamma1*q%By*0.5D0/Sqrt(Pi), -Gamma1*q%Bz*0.5D0/Sqrt(Pi), +Gamma1 ]
    !> Calculate the dU/dW.
    t = 1.0D0*q%Rho
    t2 = t**2
    UW(1,:) = [ -t2, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    UW(2,:) = [ -t2*q%Vx, t, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    UW(3,:) = [ -t2*q%Vy, 0.0D0, t, 0.0D0, 0.0D0, 0.0D0, 0.0D0 ]
    UW(4,:) = [ -t2*q%Vz, 0.0D0, 0.0D0, t, 0.0D0, 0.0D0, 0.0D0 ]
    UW(5,:) = [ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 1.0D0, 0.0D0, 0.0D0 ]
    UW(6,:) = [ 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 1.0D0, 0.0D0 ]
    UW(7,:) = [ -t2*q%V2*0.5D0, &
                +t*q%Vx, +t*q%Vy, +t*q%Vz, &
                +q%By*0.5D0/Sqrt(Pi), +q%Bz*0.5D0/Sqrt(Pi), +1.0D0/Gamma1 ]
    !> Translate Eigenvectors from W to U.
    UW = MatMul(J%OmegaR,J%OmegaL)
    J%OmegaR = MatMul(J%OmegaR, WU)
    J%OmegaL = MatMul(UW, J%OmegaL)
End Subroutine mhd_hydro_jacobian_load1D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_jacobian

Module orchid_solver_hydro_flux_roe
Use orchid_solver_params
Use orchid_solver_hydro_jacobian
Use orchid_solver_hydro_flux_godunov
Implicit None
Type, Extends(MhdHydroFlux) :: MhdHydroFluxRoe
    Contains
    Procedure, Public, NoPass, Non_Overridable :: &
        calc1D => mhd_hydro_calc_flux_roe1D, &
        calc2D => mhd_hydro_calc_flux_roe2D, &
        calc3D => mhd_hydro_calc_flux_roe3D, &
        calc3D_mhd => mhd_hydro_calc_flux_roe3D_mhd
End Type MhdHydroFluxRoe
Private :: mhd_hydro_calc_flux_roe1D, &
           mhd_hydro_calc_flux_roe2D, &
           mhd_hydro_calc_flux_roe3D, &
           mhd_hydro_calc_flux_roe3D_mhd
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_roe1D(nx, &
                                     qp, qm, flux)
    !> Calculate the Roe Fluxes in 1D.
    !> {{{
    Type(MhdHydroVars1D), Intent(In) :: qp, qm
    Real(8), Dimension(1:3), Intent(Out) :: flux
    Real(8), Intent(In) :: nx
    !> }}}
    Type(MhdHydroVars1D) :: qs
    Type(MhdHydroJacobian1D) :: Js
    Real(8) :: rp, rm
    !> Calculate Average Values.
    rp = Sqrt(qp%Rho)
    rm = sqrt(qm%Rho)
    qs%Rho = 0.5D0*( qp%Rho + qm%Rho )
    qs%Vx  = ( rp*qp%Vx + rm*qp%Vx )/( rp + rm )
    qs%Vn  = qs%Vx*nx
    qs%V2  = qs%Vx**2
    qs%kin = 0.5D0*qs%V2
    qs%ent = ( rp*qp%ent + rm*qm%ent )/( rp + rm )
    qs%c2snd = Gamma_7*qs%Rho/( qp%Rho + 2.0D0*qs%Rho + qm%Rho )
    qs%c2snd = ( ( qp%Vx - qm%Vx )**2 )*qs%c2snd
    qs%c2snd = ( rp*qp%c2snd + rm*qm%c2snd )/( rp + rm ) + qs%c2snd
    qs%c_snd = Sqrt(Max(qs%c2snd, c2min))
    !> Calculate Jacobian.
    Call mhd_hydro_jacobian_load1D(qs, Js, nx)
    Js%Lambda = Abs(Js%Lambda)
    Js%Lambda(1) = Min(Js%Lambda(1), Abs(qm%Vn - qm%c_snd))
    Js%Lambda(3) = Max(Js%Lambda(3), Abs(qp%Vn + qp%c_snd))
    !> Calculate Fluxes.
    qs%U = 0.5D0*( qp%U - qm%U )
    qs%U = [ qs%U(1), qs%U(3), qs%U(2) ]
    qs%U = MatMul(Js%OmegaL, qs%U)
    qs%U = MatMul(Js%OmegaR, Js%Lambda*qs%U)
    qs%U = [ qs%U(1), qs%U(3), qs%U(2) ]
    flux = 0.5D0*( qp%F + qm%F ) - qs%U
End Subroutine mhd_hydro_calc_flux_roe1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_roe2D(nx, ny, &
                                     qp, qm, flux)
    !> Calculate the Roe Fluxes in 2D.
    !> {{{
    Type(MhdHydroVars2D), Intent(In) :: qp, qm
    Real(8), Dimension(1:4), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny
    !> }}}
    Type(MhdHydroVars2D) :: qs
    Type(MhdHydroJacobian2D) :: Js
    Real(8) :: rp, rm
    !> Calculate Average Values.
    rp = Sqrt(qp%Rho)
    rm = sqrt(qm%Rho)
    qs%Rho = 0.5D0*( qp%Rho + qm%Rho )
    qs%Vx  = ( rp*qp%Vx + rm*qp%Vx )/( rp + rm )
    qs%Vy  = ( rp*qp%Vy + rm*qp%Vy )/( rp + rm )
    qs%Vn  = qs%Vx*nx + qs%Vy*ny
    qs%V2  = qs%Vx**2 + qs%Vy**2
    qs%kin = 0.5D0*qs%V2
    qs%ent = ( rp*qp%ent + rm*qm%ent )/( rp + rm )
    qs%c2snd = Gamma_7*qs%Rho/( qp%Rho + 2.0D0*qs%Rho + qm%Rho )
    qs%c2snd = ( ( qp%Vx - qm%Vx )**2 + ( qp%Vy - qm%Vy )**2 )*qs%c2snd
    qs%c2snd = ( rp*qp%c2snd + rm*qm%c2snd )/( rp + rm ) + qs%c2snd
    qs%c_snd = Sqrt(Max(qs%c2snd, c2min))
    !> Calculate Jacobian.
    Call mhd_hydro_jacobian_load2D(qs, Js, nx, ny)
    Js%Lambda = Abs(Js%Lambda)
    Js%Lambda(1) = Min(Js%Lambda(1), Abs(qm%Vn - qm%c_snd))
    Js%Lambda(3) = Max(Js%Lambda(3), Abs(qp%Vn + qp%c_snd))
    !> Calculate Fluxes.
    qs%U = 0.5D0*( qp%U - qm%U )
    qs%U = [ qs%U(1), qs%U(3:4), qs%U(2) ]
    qs%U = MatMul(Js%OmegaL, qs%U)
    qs%U = MatMul(Js%OmegaR, Js%Lambda*qs%U)
    qs%U = [ qs%U(1), qs%U(4), qs%U(2:3) ]
    flux = 0.5D0*( qp%F + qm%F ) - qs%U
End Subroutine mhd_hydro_calc_flux_roe2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_roe3D(nx, ny, nz, &
                                     qp, qm, flux)
    !> Calculate the Roe Fluxes in 3D.
    !> {{{
    Type(MhdHydroVars3D), Intent(In) :: qp, qm
    Real(8), Dimension(1:5), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars3D) :: qs
    Type(MhdHydroJacobian3D) :: Js
    Real(8) :: rp, rm
    !> Calculate Average Values.
    rp = Sqrt(qp%Rho)
    rm = sqrt(qm%Rho)
    qs%Rho = 0.5D0*( qp%Rho + qm%Rho )
    qs%Vx  = ( rp*qp%Vx + rm*qp%Vx )/( rp + rm )
    qs%Vy  = ( rp*qp%Vy + rm*qp%Vy )/( rp + rm )
    qs%Vz  = ( rp*qp%Vz + rm*qp%Vz )/( rp + rm )
    qs%Vn  = qs%Vx*nx + qs%Vy*ny + qs%Vz*nz
    qs%V2  = qs%Vx**2 + qs%Vy**2 + qs%Vz**2
    qs%kin = 0.5D0*qs%V2
    qs%ent = ( rp*qp%ent + rm*qm%ent )/( rp + rm )
    qs%c2snd = Gamma_7*qs%Rho/( qp%Rho + 2.0D0*qs%Rho + qm%Rho )
    qs%c2snd = ( ( qp%Vx - qm%Vx )**2 + ( qp%Vy - qm%Vy )**2 + ( qp%Vz - qm%Vz )**2 )*qs%c2snd
    qs%c2snd = ( rp*qp%c2snd + rm*qm%c2snd )/( rp + rm ) + qs%c2snd
    qs%c_snd = Sqrt(Max(qs%c2snd, c2min))
    !> Calculate Jacobian.
    Call mhd_hydro_jacobian_load3D(qs, Js, nx, ny, nz)
    Js%Lambda = Abs(Js%Lambda)
    Js%Lambda(1) = Min(Js%Lambda(1), Abs(qm%Vn - qm%c_snd))
    Js%Lambda(3) = Max(Js%Lambda(3), Abs(qp%Vn + qp%c_snd))
    !> Calculate Fluxes.
    qs%U = 0.5D0*( qp%U - qm%U )
    qs%U = [ qs%U(1), qs%U(3:5), qs%U(2) ]
    qs%U = MatMul(Js%OmegaL, qs%U)
    qs%U = MatMul(Js%OmegaR, Js%Lambda*qs%U)
    qs%U = [ qs%U(1), qs%U(5), qs%U(2:4) ]
    flux = 0.5D0*( qp%F + qm%F ) - qs%U
End Subroutine mhd_hydro_calc_flux_roe3D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Pure &
Subroutine mhd_hydro_calc_flux_roe3D_mhd(nx, ny, nz, &
                                         qp, qm, flux)
    !> Calculate the Roe Fluxes in 3D for the MHD Equations.
    !> {{{
    Type(MhdHydroVars3DMHD), Intent(In) :: qp, qm
    Real(8), Dimension(1:8), Intent(Out) :: flux
    Real(8), Intent(In) :: nx, ny, nz
    !> }}}
    Type(MhdHydroVars3DMHD) :: qs
    Type(MhdHydroJacobian1DMHD) :: Js
    Real(8) :: rp, rm
    !> Calculate Average Values.
    rp = Sqrt(qp%Rho)
    rm = sqrt(qm%Rho)
    qs%Rho = rp*rm
    qs%Vx  = ( rp*qp%Vx + rm*qp%Vx )/( rp + rm )
    qs%Vy  = ( rp*qp%Vy + rm*qp%Vy )/( rp + rm )
    qs%Vz  = ( rp*qp%Vz + rm*qp%Vz )/( rp + rm )
    qs%Bx  = ( rp*qp%Bx + rm*qp%Bx )/( rp + rm )
    qs%By  = ( rp*qp%By + rm*qp%By )/( rp + rm )
    qs%Bz  = ( rp*qp%Bz + rm*qp%Bz )/( rp + rm )
    qs%Vn  = qs%Vx*nx + qs%Vy*ny + qs%Vz*nz
    qs%V2  = qs%Vx**2 + qs%Vy**2 + qs%Vz**2
    qs%ent = ( rp*qp%ent + rm*qm%ent )/( rp + rm )
    qs%kin = 0.5D0*( qs%V2 + qs%B2/qs%rho )
    qs%eps = ( qs%ent - qs%kin )/Gamma
    qs%p   = Gamma1*qs%rho*qs%eps
    qs%p_tot = qs%p + 0.5D0*qs%B2
    qs%nrg = qs%eps + qs%kin
    qs%U(:) = [ qs%rho, &
                qs%rho*qs%nrg, &
                qs%rho*qs%Vx, qs%rho*qs%Vy, qs%rho*qs%Vz, &
                [ qs%Bx, qs%By, qs%Bz ]*2.0D0*Sqrt(Pi) ]
    qs = mhd_hydro_vars_load3D_mhd(nx, ny, nz, qs%U)
    !> Calculate Jacobian.
    Call mhd_hydro_jacobian_load1D_mhd(qp, Js)
    Js%Lambda = Abs(Js%Lambda)
    qs%U = 0.5D0*( qp%U - qm%U )
    qs%U(1:7) = [ qs%U(1), qs%U(3:5), qs%U(7:8), qs%U(2) ]
    qs%U(1:7) = MatMul(Js%OmegaL, qs%U(1:7))
    qs%U(1:7) = MatMul(Js%OmegaR, Js%Lambda*qs%U(1:7))
    qs%U = [ qs%U(1), qs%U(7), qs%U(2:4), 0.0D0, qs%U(5:6) ]
    flux = 0.5D0*( qp%F + qm%F ) - qs%U
    !flux = Abs(flux - qp%F)
End Subroutine mhd_hydro_calc_flux_roe3D_mhd
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_hydro_flux_roe


c Convert from local Cartesian coordinates to latitude & longitude

	subroutine redist(xkm, ykm, xlat, xlon)

	implicit none

c	Parameters:
	real		xkm, ykm	! km
	doubleprecision	xlat, xlon	! Degrees

	include "geocoord.inc"

c	Local variables:
	real		bcl
	integer		lat, lon
	doubleprecision lat1, lat2, lat3, clat1
	real		p, q
	real		x, y
	real		yp
	real		xx, yy

      xx=xkm
      yy=ykm

c     Rotate coordinates anticlockwise back
      y = yy*cost-xx*sint
      x = yy*sint+xx*cost
      if (abs(aa).lt.0.0000001) goto 900
      q = y/aa
      lat = (q+olat)/60.
      xlat = q+olat - 60.*lat
      yp = 60.*lat+xlat
      lat1 = datan(rlatc*dtan(yp*rad/60.0))
      lat2 = datan(rlatc*dtan(olat*rad/60.))
      lat3 = (lat1+lat2)/2.
      clat1 = dcos(lat3)
      bcl = bb*clat1
      if (abs(bcl).lt.0.000001) goto 900
      p = x/(bb*clat1)
      lon = (p+olon)/60.
      xlon = p+olon - 60.*lon
      xlat = lat+xlat/60.
      xlon = lon+xlon/60.
      return
  900 write(6,1000) aa,bb,clat1
 1000 format(/,2x,' subr. redist: aa=',f10.5,2x,'bb=',f10.5,2x,
     1'cos(lat1)=',f10.7,5x,'division by zero, run stops here',/)
      stop'redist>>> division by zero!!'
      end


C=======================================================================
C  PT_THTIME, Subroutine
C
C  Determines thermal time calculations
C-----------------------------------------------------------------------
C  Revision history
C
C               Written
C  02/28/1993 PWW Header revision and minor changes
C  08/28/2001 CHP Modified for modular format.
C=======================================================================

      SUBROUTINE PT_THTIME (
     &    ISTAGE, L0, ST, TMAX, TMIN,                     !Input
     &    DTT, STT)                                       !Output

!     ------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
!     NL defined in ModuleDefs.for

      IMPLICIT NONE

      INTEGER  ISTAGE, L0

      REAL DTT, STT, TMIN, TMAX, XTEMP
      REAL ST(NL)

C-----------------------------------------------------------------------
      DTT = 0.0
      STT = 0.0

      XTEMP = (TMAX + TMIN)/2.0
      !
      ! Thermal time leaf expansion
      !
      IF (ISTAGE .LE. 4) THEN
         IF (XTEMP .LE. 2.0) THEN
            DTT = 0.0
          ELSE IF (XTEMP .GT.  2.0 .AND. XTEMP .LE. 17.0) THEN
            DTT = 0.0667*(XTEMP - 2.0)
          ELSE IF (XTEMP .GT. 17.0 .AND. XTEMP .LE. 24.0) THEN
            DTT = 1.0
          ELSE IF (XTEMP .GT. 24.0 .AND. XTEMP .LE. 35.0) THEN
            DTT = 1.0 -0.0909*(XTEMP - 24.0)
          ELSE
            DTT = 0.0
         END IF
      END IF
      !
      ! Soil thermal time (tuber)
      !
      IF (ISTAGE .GE. 6 .OR. ISTAGE .LE. 2) THEN
         IF (ST(L0) .GE. 2.0 .AND. ST(L0) .LT. 15.0) THEN
            STT = 0.0769*(ST(L0)-2.0)
          ELSE IF (ST(L0) .GE. 15.0 .AND. ST(L0) .LT. 23.0) THEN
            STT = 1.0
          ELSE IF (ST(L0) .GE. 23.0 .AND. ST(L0) .LT. 33.0) THEN
            STT = 1.0 - 0.1*(ST(L0) - 23.0)
          ELSE
            STT = 0.0
         ENDIF
      END IF

      RETURN
      END SUBROUTINE PT_THTIME


 !
 ! This file is part of the ExaHyPE project.
 ! Copyright (c) 2016  http://exahype.eu
 ! All rights reserved.
 !
 ! The project has received funding from the European Union's Horizon
 ! 2020 research and innovation programme under grant agreement
 ! No 671698. For copyrights and licensing, please consult the webpage.
 !
 ! Released under the BSD 3 Open Source License.
 ! For the full license text, see LICENSE.txt
 !

SUBROUTINE ADERRiemannSolverNonlinear(lQbndL,lFbndL,lQbndR,lFbndR,nv)
    USE typesDef

    USE, INTRINSIC :: ISO_C_BINDING
    IMPLICIT NONE
    ! Argument list
    REAL, INTENT(IN)     :: lQbndL(nVar,nDOF(2),nDOF(3))              ! left space-time degrees of freedom
    REAL, INTENT(IN)     :: lQbndR(nVar,nDOF(2),nDOF(3))              ! right space-time degrees of freedom
    REAL, INTENT(IN)     :: nv(d)                                     ! normal vector
    REAL, INTENT(INOUT)  :: lFbndL(nVar,nDOF(2),nDOF(3))              ! left flux
    REAL, INTENT(INOUT)  :: lFbndR(nVar,nDOF(2),nDOF(3))              ! right flux
    ! Local variables
    INTEGER           :: i,j,k,l
    REAL              :: aux(d), QavL(nVar), QavR(nVar), smax
    REAL              :: LL(nVar), LR(nVar), Qav(nVar), ncp(nVar), Bn(nVar,nVar)

    !OPEN(UNIT=12, FILE="aoutput_lQbndL.txt", ACTION="write", STATUS="replace")
    !WRITE(12, '(ES24.16,1x)') , lQbndL

    !OPEN(UNIT=12, FILE="aoutput_lQbndR.txt", ACTION="write", STATUS="replace")
    !WRITE(12, '(ES24.16,1x)') , lQbndR
    !CALL EXIT

 !   PRINT *, nv
 !   CALL EXIT

    !
    ! Compute the average states from the left and the right, which we need to compute the numerical dissipation
    QavL = 0.
    QavR = 0.
    DO k = 1, nDOF(3)
      DO j = 1, nDOF(2)
            aux = (/ 1.d0, wGPN(j), wGPN(k) /)
            QavL = QavL + PRODUCT(aux(1:nDim))*lQbndL(:,j,k)
            QavR = QavR + PRODUCT(aux(1:nDim))*lQbndR(:,j,k)
        ENDDO
    ENDDO
    !
    Qav = 0.5*(QavL+QavR)
    !
    ! Here, we implement a very simple Rusanov scheme with scalar dissipation (smax*Id).
    ! We can change this into a more sophisticated Osher or HLLEM Riemann solver whenever needed!
    !
    CALL PDEEigenvalues(LL,QavL,nv)
    CALL PDEEigenvalues(LR,QavR,nv)
    smax = MAX( MAXVAL(ABS(LL)), MAXVAL(ABS(LR)) )
    !
    ! Non-conservative product with path conservative schemes
    CALL PDEMatrixB(Bn,Qav,nv)
    !
    ! We now compute the numerical flux. Note that the scheme is at the moment written in
    ! CONSERVATION FORM => no fluctuations, but real fluxes.
    ! Later, this will be converted into the left and right fluctuations.
    !
    DO k = 1, nDOF(3)
      DO j = 1, nDOF(2)
            lFbndL(:,j,k) = 0.5*( lFbndR(:,j,k) + lFbndL(:,j,k) ) - 0.5*smax*( lQbndR(:,j,k) - lQbndL(:,j,k) )
            ncp = MATMUL( Bn, lQbndR(:,j,k) - lQbndL(:,j,k) )
            lFbndR(:,j,k) = lFbndL(:,j,k) - 0.5*ncp(:)
            lFbndL(:,j,k) = lFbndL(:,j,k) + 0.5*ncp(:)
        ENDDO
    ENDDO
    !

    !PRINT *, ' --------lFbndL-ADERRiemannSolver-------------------------------- '
    !PRINT *, lFbndL
    !PRINT *, ' --------lFbndL-ADERRiemannSolver-------------------------------- '

    !OPEN(UNIT=12, FILE="aoutput_lFbndL.txt", ACTION="write", STATUS="replace")
    !WRITE(12, '(ES24.16,1x)') , lFbndL
    !CALL EXIT
END SUBROUTINE ADERRiemannSolverNonlinear


SUBROUTINE ZGESVD_F95( A, S, U, VT, WW, JOB, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: GESVD_F77 => LA_GESVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: JOB
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: S(:)
   REAL(WP), INTENT(OUT), OPTIONAL :: WW(:)
   COMPLEX(WP), INTENT(OUT), OPTIONAL, TARGET :: U(:,:), VT(:,:)
!----------------------------------------------------------------------
!
!  Purpose
!  =======
!
!       LA_GESVD and LA_GESDD compute the singular values and,
! optionally, the left and/or right singular vectors from the singular
! value decomposition  (SVD) of a real or complex m by n matrix A. The
! SVD of A is written
!                    A = U * SIGMA * V^H
! where SIGMA is an  m by n matrix which is zero except for its
! min(m, n) diagonal elements, U is an m by m orthogonal (unitary)
! matrix, and V is an n by n orthogonal (unitary) matrix. The diagonal
! elements of SIGMA , i.e., the values
!
!      sigma(i)= SIGMA(i,i), i = 1, 2,..., min(m, n)
! are the singular values of A; they are real and non-negative, and are
! returned in descending order. The first min(m, n) columns of U and V
! are the left and right singular vectors of A, respectively.
! LA_GESDD solves the same problem as LA_GESVD but uses a divide and
! conquer method if singular vectors are desired. For large matrices it
! is usually much faster than LA_GESVD when singular vectors are
! desired, but uses more workspace.
!
! Note: The routine returns V^H , not V .
!
! ========
!
!    SUBROUTINE LA_GESVD / LA_GESDD( A, S, U=u, VT=vt, &
!              WW=ww, JOB=job, INFO=info )
!      <type>(<wp>), INTENT(INOUT) :: A(:,:)
!      REAL(<wp>), INTENT(OUT) :: S(:)
!      <type>(<wp>), INTENT(OUT), OPTIONAL :: U(:,:), VT(:,:)
!      REAL(<wp>), INTENT(OUT), OPTIONAL :: WW(:)
!      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOB
!      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!      where
!      <type> ::= REAL | COMPLEX
!      <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! A      (input/output) REAL or COMPLEX array, shape (:, :) with
!        size(A, 1) = m and size(A, 2) = n.
!        On entry, the matrix A.
!        On exit, if JOB = 'U' and U is not present, then A is
!        overwritten with the first min(m, n) columns of U (the left
!        singular vectors, stored columnwise).
!        If JOB = 'V' and VT is not present, then A is overwritten with
!        the first min(m, n) rows of V^H (the right singular vectors,
!        stored rowwise).
!        In all cases the original contents of A are destroyed.
! S      (output) REAL array, shape (:) with size(S) = min(m, n).
!        The singular values of A, sorted so that S(i) >= S(i+1).
! U      Optional (output) REAL or COMPLEX array, shape (:, :) with
!        size(U, 1) = m  and size(U, 2) = m or min(m, n).
!        If size(U, 2) = m, U contains the m by m matrix U .
!        If size(U; 2) = min(m, n), U contains the first min(m, n)
!        columns of U (the left singular vectors, stored columnwise).
! VT     Optional (output) REAL or COMPLEX array, shape (:, :) with
!        size(VT, 1) = n or min(m, n) and size(VT, 2) = n.
!        If size(VT, 1) = n , VT contains the n by n matrix V^H .
!        If size(VT, 1) = min(m, n), VT contains the first min(m, n)
!        rows of V^H (the right singular vectors, stored rowwise).
! WW     Optional (output) REAL array, shape (:) with size(WW) =
!        min(m, n) - 1
!        If INFO > 0, WW contains the unconverged superdiagonal elements
!        of an upper bidiagonal matrix B whose diagonal is in SIGMA (not
!        necessarily sorted). B has the same singular values as A.
!        Note: WW is a dummy argument for LA_GESDD.
! JOB    Optional (input) CHARACTER(LEN=1).
!        = 'N': neither columns of U nor rows of V^H are returned in
!          array A.
!        = 'U': if U is not present, the first min(m, n) columns of U
!          (the left singular vectors) are returned in array A;
!        = 'V': if VT is not present, the first min(m, n) rows of V^H
!          (the right singular vectors) are returned in array A;
!        Default value: 'N'.
! INFO   Optional (output) INTEGER.
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: The algorithm did not converge.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GESVD'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOB
   CHARACTER(LEN=1) :: LJOBU, LJOBVT
   INTEGER, SAVE :: LWORK = 0
   INTEGER :: N, M, LINFO, LD, ISTAT, ISTAT1, S1U, S2U, S1VT, S2VT, &
              NN, MN, SWW
!  .. LOCAL ARRAYS ..
   COMPLEX(WP), TARGET :: LLU(1,1), LLVT(1,1)
   COMPLEX(WP), POINTER :: WORK(:)
   REAL(WP), POINTER :: RWORK(:)
   COMPLEX(WP) :: WORKMIN(1)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MIN, MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2)
   LD = MAX(1,M); MN = MIN(M,N)
   IF( PRESENT(JOB) )THEN; LJOB = JOB; ELSE; LJOB = 'N'; ENDIF
   IF( PRESENT(U) )THEN; S1U = SIZE(U,1); S2U = SIZE(U,2)
   ELSE; S1U = 1; S2U = 1; END IF
   IF( PRESENT(VT) )THEN; S1VT = SIZE(VT,1); S2VT = SIZE(VT,2)
   ELSE; S1VT = 1; S2VT = 1; END IF
   IF( PRESENT(WW) )THEN; SWW = SIZE(WW); ELSE; SWW = MN-1; ENDIF
!  .. TEST THE ARGUMENTS
   IF( M < 0 .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE( S ) /= MN )THEN; LINFO = -2
   ELSE IF( PRESENT(U) .AND. ( S1U /= M .OR. &
            ( S2U /= M .AND. S2U /= MN ) ) )THEN; LINFO = -3
   ELSE IF( PRESENT(VT) .AND. ( ( S1VT /= N .AND. S1VT /= MN ) &
            .OR. S2VT /= N ) )THEN; LINFO = -4
   ELSE IF( SWW /= MN-1 .AND. MN > 0 ) THEN; LINFO = -5
   ELSE IF( PRESENT(JOB) .AND. ( .NOT. ( LSAME(LJOB,'U') .OR. &
            LSAME(LJOB,'V') .OR. LSAME(LJOB,'N') ) .OR. &
            LSAME(LJOB,'U') .AND. PRESENT(U) .OR. &
            LSAME(LJOB,'V') .AND. PRESENT(VT)) )THEN; LINFO = -6
   ELSE
      IF( PRESENT(U) )THEN
         IF( S2U == M )THEN; LJOBU = 'A'; ELSE; LJOBU = 'S'; ENDIF
      ELSE; IF( LSAME(LJOB,'U') ) THEN; LJOBU = 'O'
         ELSE; LJOBU = 'N'; ENDIF
      ENDIF
      IF( PRESENT(VT) )THEN
         IF( S1VT == N )THEN; LJOBVT = 'A'; ELSE; LJOBVT = 'S'; ENDIF
      ELSE; IF( LSAME(LJOB,'V') )THEN; LJOBVT = 'O'
         ELSE; LJOBVT = 'N'; ENDIF
      ENDIF
        ALLOCATE( RWORK( MAX(1, 5*MIN(M,N))), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
        LWORK = -1
	IF( PRESENT(U) ) THEN
	IF ( PRESENT(VT) )THEN
	CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, U, MAX(1,S1U), &
&             VT, MAX(1,S1VT), WORKMIN, LWORK, RWORK, LINFO )
           ELSE
             CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, U, MAX(1,S1U), &
 &             LLVT, MAX(1,S1VT), WORKMIN, LWORK, RWORK, LINFO )
           ENDIF
         ELSE
           IF ( PRESENT(VT) )THEN
             CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, LLU, MAX(1,S1U), &
 &             VT, MAX(1,S1VT), WORKMIN, LWORK, RWORK, LINFO )
           ELSE
             CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, LLU, MAX(1,S1U), &
 &             LLVT, MAX(1,S1VT), WORKMIN, LWORK, RWORK, LINFO )
           ENDIF
         ENDIF
         LWORK = WORKMIN(1)
! THE NEXT LINE SHOULD BE REMOVED
         LWORK = LWORK + 1
         ALLOCATE(WORK(LWORK), STAT = ISTAT)
         IF( ISTAT /= 0 )THEN
           DEALLOCATE(WORK,STAT=ISTAT1)
	 NN = 2*MIN(M,N)+MAX(M,N)
         LWORK = MAX( 1, NN); ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT == 0) CALL ERINFO( -200, SRNAME, LINFO )
         END IF
      END IF
      IF( ISTAT == 0 ) THEN
          IF( PRESENT(U) ) THEN
  	    IF ( PRESENT(VT) )THEN
	      CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, U, MAX(1,S1U), &
	      VT, MAX(1,S1VT), WORK, LWORK, RWORK, LINFO )
	    ELSE
	      CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, U, MAX(1,S1U), &
&             LLVT, MAX(1,S1VT), WORK, LWORK, RWORK, LINFO )
            ENDIF
	  ELSE
	   IF ( PRESENT(VT) )THEN
	     CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, LLU, MAX(1,S1U), &
&             VT, MAX(1,S1VT), WORK, LWORK, RWORK, LINFO )
           ELSE
	     CALL GESVD_F77( LJOBU, LJOBVT, M, N, A, LD, S, LLU, MAX(1,S1U), &
&             LLVT, MAX(1,S1VT), WORK, LWORK, RWORK, LINFO )
           ENDIF
	 ENDIF
         LWORK = INT(WORK(1)+1)
         IF( LINFO > 0 .AND. PRESENT(WW) ) WW(1:MN-1) = RWORK(1:MN-1)
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, RWORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE ZGESVD_F95


SUBROUTINE cal_pole(theta, phi, theta_p, phi_p, thp, php)
! does some funky stuff to calculate various angles
    real theta, phi, theta_p, phi_p, thp, php, offset
    real pdiff, costhp, sinphp, cosphp, tnum, tden
    real eps, pi, d2r

    eps=1.0e-6
    pi=4.0*atan(1.0)
    d2r=pi/180.0

    if (abs(theta_p).le.eps) then
        thp=theta
        php=phi
        return
    endif

    offset = atan(tan(pi-d2r*phi_p)*cos(d2r*theta_p))
    pdiff = d2r*(phi-phi_p)
    costhp = cos(d2r*theta)*cos(d2r*theta_p)+sin(d2r*theta)*sin(d2r*theta_p)*cos(pdiff)

    if (costhp.ge.1.0-eps) then
        thp=0.0
        php=0.0-offset/d2r
        return
    else
        thp=acos(costhp)/d2r
        sinphp=sin(d2r*theta)*sin(pdiff)/sin(d2r*thp)
        cosphp=(cos(d2r*theta)*sin(d2r*theta_p)-sin(d2r*theta)*cos(d2r*theta_p)*cos(pdiff))/sin(d2r*thp)
        if (abs(sinphp).le.eps) then
            if (cosphp.gt.eps) then
                php=0.0-offset/d2r
            else
                php=180.0-offset/d2r
            endif
            return
        else if (abs(cosphp).le.eps) then
            if (sinphp.gt.eps) then
                php=90.0-offset/d2r
            else
                php=-90.0-offset/d2r
            endif
            return
        endif
    endif

    tnum=sin(d2r*theta)*sin(pdiff)
    tden=(cos(d2r*theta)*sin(d2r*theta_p)-sin(d2r*theta)*cos(d2r*theta_p)*cos(pdiff))
    php=(atan2(tnum,tden)-offset)/d2r
    return
END SUBROUTINE cal_pole


module modMomentum

    use modValues
    implicit none

    contains

    !========= Pressure Equations ============
    subroutine getMomentum(solMethod)
        implicit none

        character(len=*) :: solMethod

        if( trim(solMethod) == 'impCoeff' ) then
            CALL getMomentumCoeff
        elseif( trim(solMethod) == 'dP_to_U' ) then
            CALL updateVelocity
        endif

    endsubroutine

    subroutine getMomentumCoeff
        implicit none
        real(8) :: save_dummy(ncell),save_Bmat(ncell)

        CALL getCoeff

        !> Update to Velocity
        do i=nCellStr,nCellEnd
            coeffMom1(i) = &
                dot_product(AmatMom(i,nCellStr:nCellEnd),&
                            BmatMom1(nCellStr:nCellEnd))

            coeffMom2(i) = &
                dot_product(AmatMom(i,nCellStr:nCellEnd),&
                            BmatMom2(nCellStr:nCellEnd))

            cDU(i) = ( coeffMom1(i) +coeffMom2(i) ) - cU(i)
            cU(i) = cU(i) + underRelaxFactU*cDU(i)
        enddo

    endsubroutine

    subroutine getCoeff
        use modFaceValues
        implicit none

        CALL getFaceValues(&
            FaceMethodU=chFluxU,FaceMethodP=chFluxP &
            )

        !> Calc. Matix of Linear System about Momentum Eq.
        !> A*x=B
        do i=nCellStr,nCellEnd
            lFace = i-1; rFace = i
                !> | (i-1) |-> (i) |-> (i+1) |
            AmatMom(i,i) = &
                            + cRho(i)/timestep &
                            - fgN(lFace)*fMdot(lFace) / cVol(i) &
                            + fgP(rFace)*fMdot(rFace) / cVol(i)
            if( i/=nCellStr ) then
                AmatMom(i,i-1) = &
                            - fgP(lFace)*fMdot(lFace) / cVol(i)
            endif
            if( i/=nCellEnd ) then
                AmatMom(i,i+1) = &
                            + fgN(rFace)*fMdot(rFace) / cVol(i)
            endif

            BmatMom1(i)   = oldCons(i,2) / timestep
            BmatMom2(i)   = ( fP(lFace)*area(lFace) &
                            - fP(rFace)*area(rFace) ) / cVol(i)
        enddo
        !> inverse of AmatMom
        CALL matInverse(AmatMom,nCellEnd)

    endsubroutine

    !========================================================

    subroutine updateVelocity
        use modFaceValues
        implicit none

        real(8) :: save_Bmat(ncell)
        real(8) :: lfVelx,rfVelx,lfPx,rfPx

        CALL getFaceValues(&
            FaceMethodU=chFluxU &
            )

        !> Calc. Matix of Linear System about Momentum Eq.
        do i=nCellStr,nCellEnd
            lFace = i-1; rFace = i

            !lfPx = fP(lFace)
            !rfPx = fP(rFace)

            lfPx = fgP(lFace)*cDp(i-1)  + fgN(lFace)*cDp(i)
            rfPx = fgP(rFace)*cDp(i)  + fgN(rFace)*cDp(i+1)

            save_Bmat(i) = ( lfPx*area(lFace) - rfPx*area(rFace) )

        enddo

        cDU(nCellStr:nCellEnd) = &
            underRelaxFactU &
            *matmul(AmatMom(nCellStr:nCellEnd,nCellStr:nCellEnd),&
                    save_Bmat(nCellStr:nCellEnd))

        cU(nCellStr:nCellEnd) = cU(nCellStr:nCellEnd) + cDU(nCellStr:nCellEnd)

    endsubroutine

    !subroutine getVelocity3
    !    implicit none
    !
    !    do i=nFaceStr,nFaceEnd
    !        lCell = i; rCell = i+1
    !        wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
    !        wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
    !        CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
    !        fMdot(i) = fMdot(i)*area(i)
    !        fgP(i) = 0.5d0*(1.d0+dsign(1.d0,fU(i)))
    !        fgN(i) = 0.5d0*(1.d0-dsign(1.d0,fU(i)))
    !        fUx(i) = fgP(i)*cU(lCell) + fgN(i)*cU(rCell)
    !    enddo
    !    !> Calc. Matix of Linear System about Momentum Eq.
    !    !> A*x=B
    !    AmatMom(:,:) = 0.d0
    !    do i=nCellStr,nCellEnd
    !        lFace = i-1; rFace = i
    !            !> | (i-1) |-> (i) |-> (i+1) |
    !        AmatMom(i,i) = AmatMom(i,i) &
    !                        + cRho(i)/timestep &
    !                        + fMdot(rFace)*fgP(rFace) / cVol(i) &
    !                        - fMdot(lFace)*fgN(lFace) / cVol(i)
    !        if( i/=nCellStr ) then
    !            AmatMom(i,i-1) = AmatMom(i,i-1) &
    !                            - fMdot(lFace)*fgP(lFace) / cVol(i)
    !        endif
    !        if( i/=nCellEnd ) then
    !            AmatMom(i,i+1) = AmatMom(i,i+1) &
    !                            + fMdot(rFace)*fgN(rFace) / cVol(i)
    !        endif
    !        BmatMom1(i)   = oldcRho(i)*oldcU(i)/timestep
    !        BmatMom2(i)   = ( fP(lFace)*area(lFace) &
    !                        - fP(rFace)*area(rFace) ) / cVol(i)
    !    enddo
    !    !> inverse of AmatMom
    !    CALL matInverse(AmatMom,nCellEnd)
    !    !> Update to Velocity
    !    coeffMom1(nCellStr:nCellEnd) = &
    !                    matmul(AmatMom(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                            BmatMom1(nCellStr:nCellEnd))
    !    coeffMom2(nCellStr:nCellEnd) = &
    !                    matmul(AmatMom(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                            BmatMom2(nCellStr:nCellEnd))
    !    cDu(nCellStr:nCellEnd) = ( coeffMom1(nCellStr:nCellEnd) &
    !                                -coeffMom2(nCellStr:nCellEnd) ) &
    !                                - cU(nCellStr:nCellEnd)
    !    cU(nCellStr:nCellEnd) = cU(nCellStr:nCellEnd) &
    !                            + cDu(nCellStr:nCellEnd)
    !
    !
    !endsubroutine
    !
    !
    !
    !
    !subroutine getVelocity2
    !    implicit none
    !
    !    real(8) :: save_dummy(ncell)
    !
    !    do i=nFaceStr,nFaceEnd
    !        lCell = i; rCell = i+1
    !        wL(:) = (/cRho(lCell),cU(lCell),cP(lCell)/)
    !        wR(:) = (/cRho(rCell),cU(rCell),cP(rCell)/)
    !        CALL calfaceValAUSM(wL,wR,eosGamma, fMdot(i),fU(i),fP(i))
    !    enddo
    !    !> Calc. Matix of Linear System about Momentum Eq.
    !    do i=nCellStr,nCellEnd
    !        lFace = i-1; rFace = i
    !        !BmatMom1(i)   = oldcRho(i)*oldcU(i)/timestep
    !        BmatMom2(i)   = ( fP(lFace)*area(lFace) &
    !                        - fP(rFace)*area(rFace) ) / cVol(i)
    !    enddo
    !    !> inverse of AmatMom
    !    !CALL matInverse(AmatMom,nCellEnd)
    !    !> Update to Velocity
    !    !coeffMom1(nCellStr:nCellEnd) = &
    !    !                matmul(AmatMom(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !    !                        BmatMom1(nCellStr:nCellEnd))
    !
    !    save_dummy(nCellStr:nCellEnd) = cU(nCellStr:nCellEnd)
    !
    !    coeffMom2(nCellStr:nCellEnd) = &
    !                    matmul(AmatMom(nCellStr:nCellEnd,nCellStr:nCellEnd),&
    !                           BmatMom2(nCellStr:nCellEnd))
    !
    !    cU(nCellStr:nCellEnd) = ( coeffMom1(nCellStr:nCellEnd) &
    !                             +coeffMom2(nCellStr:nCellEnd) )
    !
    !    cDu(nCellStr:nCellEnd) = cU(nCellStr:nCellEnd) &
    !                            -save_dummy(nCellStr:nCellEnd)
    !
    !
    !endsubroutine

endmodule


subroutine eqfor(bu, bv, bsq, rmag, zmag)

      use stel_kinds, only: dp
      use name0, only: cp5, c1p5, czero
      use name1, only: nmax, nznt
      use scalars, only: ns, dnorm, isigng, ohs, twopi, voli
      use profs, only: pres, phips, vp, iotas
      use scalefac, only: wint
      use extfld, only: bscale
      use current, only: buco, bvco, jv, ju
      use fsqu, only: equif
      use spectra, only: specw
      use mnarray, only: mscale, nscale

      implicit none

      ! TODO: more elegant definition of these BLAS functions
      real(kind=dp) :: ddot

      real(kind=dp), intent(in) :: bu  (ns,1)
      real(kind=dp), intent(in) :: bv  (ns,1)
      real(kind=dp), intent(in) :: bsq (ns,1)
      real(kind=dp), intent(in) :: rmag(ns,0:nmax)
      real(kind=dp), intent(in) :: zmag(ns,0:nmax)

      integer       :: i, js, n
      real(kind=dp) :: betaxis, es, aiotaf, volf
      real(kind=dp) :: t0, t1, t2, t3
      real(kind=dp) :: phi1, chi1

      write(3,5)
  5   format(/,'     S       EQUIF      PHI       CHI     <JTHETA>     IOTA     <JZETA>   <BSUBV>    P''/V''    V''/PHIP   <M>',/)

      ! compute beta at axis before pressure re-normalization
      betaxis =  c1p5*pres(2)/(dnorm * ddot(nznt, bsq(2,1), ns, wint(2), ns) - pres(2)) &
               -  cp5*pres(3)/(dnorm * ddot(nznt, bsq(3,1), ns, wint(2), ns) - pres(3))

      phi1 = czero
      chi1 = czero
      do i = 2,ns
        buco(i)  = dnorm/bscale * ddot(nznt, bu(i,1), ns, wint(2), ns)
        bvco(i)  = dnorm/bscale * ddot(nznt, bv(i,1), ns, wint(2), ns)

        pres(i)  = pres(i)/bscale**2
        phips(i) = phips(i)/bscale
      end do

      do js = 2, ns-1
        es = (js-1)/real(ns-1)

        t0     = cp5*(   vp(js) +    vp(js+1))
        aiotaf = cp5*(iotas(js) + iotas(js+1))

        jv(js) =  isigng*ohs*(buco(js+1) - buco(js))/t0
        ju(js) = -isigng*ohs*(bvco(js+1) - bvco(js))/t0

        t1 = jv(js)*aiotaf
        t2 = ohs*(pres(js+1) - pres(js))/t0
        t3 = cp5*(vp(js+1)/phips(js+1) + vp(js)/phips(js))

        phi1 = phi1 + phips(js)          /ohs
        chi1 = chi1 + phips(js)*iotas(js)/ohs

        equif(js) = (ju(js) - t1 - t2*t3) / (abs(ju(js)) + abs(t1) + abs(t2*t3))

        write(3,30) es, equif(js), &
                    isigng*twopi*phi1, &
                    isigng*twopi*chi1, &
                    ju(js), aiotaf, jv(js), bvco(js), t2, t3, specw(js)
      end do
 30   FORMAT(1P5E10.2,1p1E11.3,1P3E10.2,1P1E11.3,0PF7.3)

      volf = (twopi**2)*sum(vp(1:ns))/real(ns-1)
      write(3,40) voli, volf, betaxis
 40   format(/,'  INITIAL VOLUME  =  ',1pe20.10,'  FINAL VOLUME  =  ',1pe20.10,/, &
               '  BETA ON AXIS    =  ',2x,1pe12.4,/)

      write(3,50)
 50   format(2x,'MAGNETIC AXIS COEFFICIENTS',/,&
                '    n     rmag       zmag',/)
      do n = 0, nmax
        t1 = mscale(0)*nscale(n)

        ! TODO: why is the z coeff inverted ?
        write(3,70) n, t1*rmag(1,n), -t1*zmag(1,n)
      end do
 70   format(i5,1p2e12.4)

      return
end


PROGRAM using_integers_and_reals
  IMPLICIT none
  REAL     :: a, b, c, d, e, f, result, error
  INTEGER  :: i, j, k, l, m

  i = 1;    j = 2
  a = 3.0;    b = 2.0

  result = (a+b)*(a/b - 3.0)
  j = j + 1
  k = i/j
  l = j+j/2
  m = i**j
  c = a/2.0*b
  d = i/j
  error = 10**(-3)
  e = REAL(i)/REAL(j)
  f = 3.0E-4*b - 2.0E-4*a

  WRITE(6,*)  'result = ',result
  WRITE(6,*)  'j = ',j
  WRITE(6,*)  'k = ',k
  WRITE(6,*)  'l = ',l
  WRITE(6,*)  'm = ',m
  WRITE(6,*)  'c = ',c
  WRITE(6,*)  'd = ',d
  WRITE(6,*)  'error = ',error
  WRITE(6,*)  'e = ',e
  WRITE(6,*)  'f = ',f

END PROGRAM using_integers_and_reals


!
!     -------------------------------------------------------------
!      J T H N
!     -------------------------------------------------------------
!
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
      INTEGER FUNCTION JTHN (K, N, I)
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:53:44  11/16/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: K
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: I
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      SELECT CASE (N)
      CASE (1)
         JTHN = MOD(K,I)
      CASE (2)
         JTHN = MOD(K/I,I)
      CASE (3)
         JTHN = MOD(K/(I*I),I)
      CASE (4)
         JTHN = MOD(K/(I*I*I),I)
      CASE (5)
         JTHN = MOD(K/(I*I*I*I),I)
      CASE DEFAULT
         WRITE (6, '(A)') ' ERROR IN JTHN '
         STOP
      END SELECT
      RETURN
      END FUNCTION JTHN


	subroutine GDSTAT (lu,mx,my,mz,a,h,atype,htype,amiss,header,inc)

c	..Print statistics of one 3-d variable
	implicit none

	integer lu		! Output unit
	integer mx,my,mz	! Array sizes
	real a(mx,my,mz)	! The array
	real h(mz)		! The argument(levels)
	character*4 atype	! Type of the variable
	character*4 htype	! Typf of the levels
	real amiss		! missing value flag of a
	character*(*) header	! A header message
	integer inc		! order of the listing

	integer i,j,k
	integer kfr,kto,kinc
	integer imx,imn,jmx,jmn
	integer knt
	real amx,amn
	real avg,dev,d
	logical first

c	..A practical value for the magnitude of the fraction of a real
c	number.

	real rfrcval
	parameter(rfrcval=1.e-5)

c	..function

	logical spv
	real aspv
	spv(aspv)=abs((aspv-amiss)/amiss).le.rfrcval

	write(lu,'(/a)') header
	if(htype.eq.'PRES') then
	  write(lu,'(a,3x,a,2x,a,5x,a,6x,a,9x,a,15x,a)') 'lvl','mbar',
     >	    'count','mean','stdv','maxi','mini'
	elseif(htype.eq.'HGHT') then
	  write(lu,'(a,2x,a,2x,a,5x,a,6x,a,9x,a,15x,a)') 'lvl','meter',
     >	    'count','mean','stdv','maxi','mini'
	elseif(htype.eq.'TEMP') then
	  write(lu,'(a,4x,a,4x,a,5x,a,6x,a,9x,a,15x,a)') 'lvl','K',
     >	    'count','mean','stdv','maxi','mini'
	else
	  write(lu,'(a,4x,a,4x,a,5x,a,6x,a,9x,a,15x,a)') 'lvl',htype,
     >	    'count','mean','stdv','maxi','mini'
	endif

c	..Check the order of the listing, increase or decrease
	if(inc.ge.0) then
	  kfr=1
	  kto=mz
	  kinc=1
	else
	  kfr=mz
	  kto=1
	  kinc=-1
	endif

	do k=kfr,kto,kinc
	  knt=0
	  avg=0.
	  do j=1,my
	    do i=1,mx
	      if(.not.spv(a(i,j,k))) then
		knt=knt+1
	      	avg=avg+a(i,j,k)
	      endif
	    end do
	  end do
	  avg=avg/max(1,knt)

	  dev=0.
	  do j=1,my
	    do i=1,mx
	      if(.not.spv(a(i,j,k))) then
		d=a(i,j,k)-avg
		dev=dev+d*d
	      endif
	    end do
	  end do
	  dev=sqrt(dev/max(1,knt-1))

	  amx=a(1,1,k)
	  amn=a(1,1,k)
	  first=.true.
	  do j=1,my
	    do i=1,mx
	      if(.not.spv(a(i,j,k))) then
		if(first) then
		  imx=i
		  imn=i
		  jmx=j
		  jmn=j
		  amx=a(imx,jmx,k)
		  amn=a(imn,jmn,k)
		  first=.false.
		else
		  if(a(i,j,k).gt.amx) then
		    amx=a(i,j,k)
		    imx=i
		    jmx=j
		  endif
	      	  if(a(i,j,k).lt.amn) then
		    amn=a(i,j,k)
		    imn=i
		    jmn=j
		  endif
		endif
	      endif
	    end do
	  end do

	  if(atype.eq.'RELH') then
	    avg=avg*100.
	    dev=dev*100.
	    amx=amx*100.
	    amn=amn*100.
	  endif

	  if(htype.eq.'PRES'.or.htype.eq.'HGHT') then
	    if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	      write(lu,'(i3,2i7,2i10,'//
     &		'2(i10,a,i3,a,i3,a))')
     &		k,nint(h(k)),knt,nint(avg),nint(dev),
     &		nint(amx),'(',imx,',',jmx,')',
     &		nint(amn),'(',imn,',',jmn,')'
	    elseif(atype.eq.'TEMP'.or.atype.eq.'PRES'.or.
     &	      atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	      atype.eq.'RELH'.or.atype.eq.'MIXR') then
	      write(lu,'(i3,2i7,2f10.2,'//
     &		'2(f10.2,a,i3,a,i3,a))')
     &		k,nint(h(k)),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    elseif(atype.eq.'NORM') then
	      write(lu,'(i3,2i7,2f10.4,'//
     &		'2(f10.4,a,i3,a,i3,a))')
     &		k,nint(h(k)),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    else
	      write(lu,'(i3,2i7,1p,2e10.3e1,0p,'//
     &		'2(1p,e10.3e1,0p,a,i3,a,i3,a))')
     &		k,nint(h(k)),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    endif

	  elseif(htype.eq.'TEMP') then
	    if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	      write(lu,'(i3,f7.2,i7,2i10,'//
     &		'2(i10,a,i3,a,i3,a))')
     &		k,h(k),knt,nint(avg),nint(dev),
     &		nint(amx),'(',imx,',',jmx,')',
     &		nint(amn),'(',imn,',',jmn,')'
	    elseif(atype.eq.'TEMP'.or.atype.eq.'PRES'.or.
     &	      atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	      atype.eq.'RELH'.or.atype.eq.'MIXR') then
	      write(lu,'(i3,f7.2,i7,2f10.2,'//
     &		'2(f10.2,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    elseif(atype.eq.'NORM') then
	      write(lu,'(i3,f7.2,i7,2f10.4,'//
     &		'2(f10.4,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    else
	      write(lu,'(i3,f7.2,i7,1p,2e10.3e1,0p,'//
     &		'2(1p,e10.3e1,0p,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    endif

	  else
	    if(atype.eq.'HGHT'.or.atype.eq.'STRM') then
	      write(lu,'(i3,1p,e10.3e1,0p,i7,2i10,'//
     &		'2(i10,a,i3,a,i3,a))')
     &		k,h(k),knt,nint(avg),nint(dev),
     &		nint(amx),'(',imx,',',jmx,')',
     &		nint(amn),'(',imn,',',jmn,')'
	    elseif(atype.eq.'TEMP'.or.atype.eq.'PRES'.or.
     &	      atype.eq.'WIND'.or.atype.eq.'%REH'.or.
     &	      atype.eq.'RELH'.or.atype.eq.'MIXR') then
	      write(lu,'(i3,1p,e10.3e1,0p,i7,2f10.2,'//
     &		'2(f10.2,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    elseif(atype.eq.'NORM') then
	      write(lu,'(i3,1p,e10.3e1,0p,i7,2f10.4,'//
     &		'2(f10.4,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    else
	      write(lu,'(i3,1p,e10.3e1,0p,i7,1p,2e10.3e1,0p,'//
     &		'2(1p,e10.3e1,0p,a,i3,a,i3,a))')
     &		k,h(k),knt,avg,dev,
     &		amx,'(',imx,',',jmx,')',
     &		amn,'(',imn,',',jmn,')'
	    endif

	  endif
	end do		! k=kfr,kto,kinc

	end	! gdstat()


      SUBROUTINE PREP_SECT2_REAL(AS2,JS2,NVAL,IB,ID,RMINA)
C
C        MAY     2000   LAWRENCE   GSC/TDL   ORIGINAL CODING
C        JANUARY 2001   GLAHN      REMOVED MAXA; COMMENTS
C        JANUARY 2001   GLAHN/LAWRENCE CHANGED 10**IB TO 2**IB;
C                                  CHANGED JS2(K)*JE TO JS2(K)/JE
C        JANAURY 2001   LAWRENCE   CHANGED JE=2**IB TO JE=2**(-IB)
C                                  AND NOW MULTIPLY THE VALUES IN
C                                  JS2( ) BY JE INSTEAD OF DIVIDING
C                                  BY IT.
C        NOVEMBER 2001   GLAHN     COMMENT ABOUT IB
C
C        PURPOSE
C            PREPARES THE LOCAL DATA TO BE
C            PACKED USING THE SIMPLE PACKING METHOD.  THE
C            PREPARATION OF THE DATA ENCOMPASSES MULTIPLYING
C            ALL OF THE DATA ELEMENTS IN THE FIELD BY
C            THE DECIMAL SCALING FACTOR, REMOVING THE MINIMUM
C            VALUE, AND DIVIDING ALL OF THE DATA ELEMENTS
C            IN THE FIELD BY THE BINARY SCALING FACTOR.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              AS2(K) = CONTAINS THE LOCAL DATA TO BE PACKED USING
C                       THE SIMPLE PACKING METHOD IN THE LOCAL USE
C                       SECTION OF THE GRIB2 MESSAGE (K=1,NVAL).
C                       (INPUT)
C              JS2(K) = ONCE THE DATA IN AS2( ) HAS BEEN SCALED AND THE
C                       REFERENCE VALUE HAS BEEN REMOVED, IT IS COPIED
C                       INTO THIS INTEGER ARRAY AND RETURNED TO THE
C                       CALLER OF THIS ROUTINE.  (OUTPUT)
C                NVAL = THE DIMENSION OF JS2( ) AND AS2( ).  (INPUT)
C                  IB = THE BINARY SCALING FACTOR.  THIS IS
C                       0 IN THE CALLING PROGRAM PK_SECT2, AND
C                       HAS NO EFFECT ON THE RESULT.  (INPUT)
C                  ID = THE DECIMAL SCALING FACTOR.  (INPUT)
C               RMINA = THE FIELD MINIMUM VALUE.  (OUTPUT)
C
C             LOCAL VARIABLES
C                   D = THE DECIMAL MULTIPLICATION FACTOR, 10.**ID.
C                   E = THE BINARY MULTIPLICATION FACTOR, 2.**IE.
C                   K = LOOP INDEXING VARIABLE.
C
C        NON SYSTEM SUBROUTINES CALLED
C           NONE
C
      DIMENSION AS2(NVAL),JS2(NVAL)
C
C     SCALE THE DATA FIELD BY THE DECIMAL SCALING FACTOR.
C
      IF(ID.NE.0)THEN
         D=10.**(INT(ID))
C
         DO 10 K=1,NVAL
            AS2(K)=AS2(K)*D
 10      CONTINUE
C
      ENDIF
C
C        FIND THE MINIMUM OF THE DATA FIELD.
      RMINA=AS2(1)
C
      DO 20 K=2,NVAL
C
         IF(AS2(K).LT.RMINA)THEN
           RMINA=AS2(K)
         ENDIF
C
 20   CONTINUE
C
C        SUBTRACT OUT THE MINIMUM FROM THE DATA
C        FIELD.
C
      DO 30 K=1,NVAL
         AS2(K)=AS2(K)-RMINA
 30   CONTINUE
C
C        MULTIPLY THE DATA FIELD BY THE BINARY
C        SCALING FACTOR.
C
      IF(IB.NE.0)THEN
         E=2.**(INT(-IB))
C
         DO 40 K=1,NVAL
            AS2(K)=AS2(K)*E
 40      CONTINUE
C
      ENDIF
C
C        COPY THE FLOATING POINT VALUES INTO THE
C        INTEGER OUTPUT ARRAY.
      DO 50 K=1,NVAL
         JS2(K)=NINT(AS2(K))
 50   CONTINUE
C
      RETURN
      END


      SUBROUTINE QROOT(P,N,B,C,EPS)
      PARAMETER (NMAX=20,ITMAX=20,TINY=1.0E-6)
      DIMENSION P(N),Q(NMAX),D(3),REM(NMAX),QQ(NMAX)
      D(3)=1.
      DO 12 ITER=1,ITMAX
        D(2)=B
        D(1)=C
        CALL POLDIV(P,N,D,3,Q,REM)
        S=REM(1)
        R=REM(2)
        CALL POLDIV(Q,N-1,D,3,QQ,REM)
        SC=-REM(1)
        RC=-REM(2)
        DO 11 I=N-1,1,-1
          Q(I+1)=Q(I)
11      CONTINUE
        Q(1)=0.
        CALL POLDIV(Q,N,D,3,QQ,REM)
        SB=-REM(1)
        RB=-REM(2)
        DIV=1./(SB*RC-SC*RB)
        DELB=(R*SC-S*RC)*DIV
        DELC=(-R*SB+S*RB)*DIV
        B=B+DELB
        C=C+DELC
        IF((ABS(DELB).LE.EPS*ABS(B).OR.ABS(B).LT.TINY)
     *      .AND.(ABS(DELC).LE.EPS*ABS(C)
     *      .OR.ABS(C).LT.TINY)) RETURN
12    CONTINUE
      PAUSE 'too many iterations in QROOT'
      END


!
!     ------------------------------------------------------------------
!              H W F
!     ------------------------------------------------------------------
!
!       Returns the value of an unnormalized (nl) hydrogenic function
!   with nuclear charge ZZ and radius r.
!
!
      REAL(KIND(0.0D0)) FUNCTION HWF (N, L, ZZ, R)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE PARAM_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: L
      REAL(DOUBLE) , INTENT(IN) :: ZZ
      REAL(DOUBLE) , INTENT(IN) :: R
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, I
      REAL(DOUBLE) :: P, A, B, C, X
!-----------------------------------------------
      K = N - L - 1
      P = D1
      A = D1
      B = K
      C = N + L
      X = -D2*ZZ*R/N
!
!  *****  TEST IF UNDERFLOW MAY OCCUR, IF SO SET HWF = 0
!
      IF (X >= (-150.D0)) THEN
         IF (K >= 0) THEN
            IF (K /= 0) THEN
               DO I = 1, K
                  P = D1 + A/B*P/C*X
                  A = A + D1
                  B = B - D1
                  C = C - D1
               END DO
            ENDIF
            HWF = P*DEXP(X/D2)*(-X)**(L + 1)
            RETURN
         ENDIF
         WRITE (6, 7) N, L, ZZ, R
    7    FORMAT(' FORBIDDEN COMBINATION OF N AND L IN HWF SUBPROGRAM'/,' N =',&
            I4,'   L =',I4,'   Z =',F6.1,'   R =',F8.4)
         STOP
      ENDIF
      HWF = D0
      RETURN
      END FUNCTION HWF