C$Procedure    QMINI ( Quaternion linear interpolation )

      SUBROUTINE QMINI ( INIT, FINAL, FRAC, QINTRP )
      IMPLICIT NONE

C$ Abstract
C
C     Interpolate between two quaternions using a constant angular
C     rate.
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     ROTATIONS
C
C$ Keywords
C
C     MATH
C     QUATERNION
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION      INIT   ( 0 : 3 )
      DOUBLE PRECISION      FINAL  ( 0 : 3 )
      DOUBLE PRECISION      FRAC
      DOUBLE PRECISION      QINTRP ( 0 : 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     INIT       I   Initial quaternion representing a rotation.
C     FINAL      I   Final quaternion representing a rotation.
C     FRAC       I   Fraction of rotation from INIT to FINAL by which
C                    to interpolate.
C     QINTRP     O   Linearly interpolated quaternion.
C
C$ Detailed_Input
C
C     INIT,
C     FINAL,
C     FRAC           are, respectively, two unit quaternions between
C                    which to interpolate, and an interpolation
C                    fraction.  See the Detailed_Output and Particulars
C                    sections for details.
C
C$ Detailed_Output
C
C     QINTRP         is the quaternion resulting from linear
C                    interpolation between INIT and FINAL by the
C                    fraction FRAC.  By "linear interpolation" we mean
C                    the following:
C
C                       We view INIT and FINAL as quaternions
C                       representing two values of a time-varying
C                       rotation matrix R(t) that rotates at a constant
C                       angular velocity (that is, the row vectors of
C                       R(t) rotate with constant angular velocity).
C                       We can say that
C
C                          INIT  represents R(t0)
C                          FINAL represents R(t1)
C
C                       Equivalently, the SPICELIB routine Q2M maps
C                       INIT and FINAL to rotation matrices
C                       corresponding to R(t0) and R(t1) respectively.
C
C                       "Linear interpolation by the fraction FRAC"
C                       means that QINTRP represents the matrix
C                       R(t) evaluated at time
C
C                          t = t0   +   FRAC * (t1 - t0)
C
C                       and that the sign of QINTRP is such that
C                       QINTRP is closer to both INIT and FINAL
C                       than is -QINTRP.
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If either of INIT or FINAL is not a unit quaternion, the error
C         SPICE(NOTAROTATION) is signaled.
C
C     2)  This routine assumes that the quaternion QUOT defined by
C
C                               *
C            QUOT = FINAL * INIT
C
C         has rotation angle THETA radians, where
C
C            0  <  THETA  <  pi
C               -
C
C         Above the * superscript denotes quaternion conjugation.
C
C         The caller must test this condition on THETA; it is not
C         tested by this routine. A quick check may be performed by
C         verifying that
C
C            0  <  QUOT(0)
C
C         Note that this inequality is strict because rotations of
C         pi radians cannot be linearly interpolated so as to
C         produce a unique result.
C
C         This routine cannot distinguish between rotations of THETA
C         radians, where THETA is in the interval [0, pi), and
C         rotations of
C
C            THETA   +   2 * k * pi
C
C         radians, where k is any integer. These "large" rotations will
C         yield invalid results when interpolated.  You must ensure
C         that the inputs you provide to this routine will not be
C         subject to this sort of ambiguity.  If in fact you are
C         interpolating a time-dependent rotation with constant angular
C         velocity AV between times t0 and t1, you must ensure that
C
C            || AV ||  *  |t1 - t0|   <   pi.
C
C         Here we assume that the magnitude of AV is the angular rate
C         of the rotation in units of radians per second.
C
C
C     3)  When FRAC is outside of the interval [0, 1], the process
C         performed is "extrapolation", not interpolation.  Such
C         values of FRAC are permitted.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     In the discussion below, we assume that the conditions specified
C     in item (2) of the Exceptions section have been satisfied.
C
C     As we've said, we view INIT and FINAL as quaternions representing
C     two values of a time-varying rotation matrix R(t) that rotates at
C     a constant angular velocity; we define R(t), t0, and t1 so that
C
C        INIT  represents  R(t0)
C        FINAL represents  R(t1).
C
C     The output quaternion QINTRP represents R(t) evaluated at the
C     time
C
C        t0   +   FRAC * (t1 - t0).
C
C     How do we evaluate R at times between t0 and t1? Since the row
C     vectors of R are presumed to rotate with constant angular
C     velocity, we will first find the rotation axis of the quotient
C     rotation Q that maps the row vectors of R from their initial to
C     final position.  Since the rows of R are the columns of the
C     transpose of R, we can write:
C
C             T               T
C        R(t1)   =   Q * R(t0),
C
C     Since
C
C             T            T                  T
C        R(t1)   =  ( R(t1)  * R(t0) ) * R(t0)
C
C
C     we can find Q, as well as a rotation axis A and an angle THETA
C     in the range [0, pi] such that Q rotates vectors by THETA
C     radians about axis A.
C
C     We'll use the notation
C
C        [ x ]
C             N
C
C     to indicate a coordinate system rotation of x radians about the
C     vector N.  Having found A and THETA, we can write (note that
C     the sign of the rotation angle is negated because we're using
C     a coordinate system rotation)
C
C            T                  (t  - t0)                T
C        R(t)   =  [ - THETA *  ---------  ]    *   R(t0)
C                               (t1 - t0)   A
C
C     Thus R(t) and QINTRP are determined.
C
C     The input argument FRAC plays the role of the quotient
C
C        t  - t0
C        -------
C        t1 - t0
C
C     shown above.
C
C
C$ Examples
C
C     1)  Suppose we want to interpolate between quaternions
C         Q1 and Q2 that give the orientation of a spacecraft structure
C         at times t1 and t2.  We wish to find an approximation of the
C         structure's orientation at the midpoint of the time interval
C         [t1, t2].  We assume that the angular velocity of the
C         structure equals the constant AV between times t1 and t2.  We
C         also assume that
C
C            || AV ||  *  (t2 - t1)   <   pi.
C
C         Then the code fragment
C
C            CALL QMINI ( Q1, Q2, 0.5D0, QINTRP, SCLDAV )
C
C         produces the approximation we desire.
C
C
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 1.0.1, 28-FEB-2008 (NJB)
C
C        The discussion of exception #2 was expanded.
C
C-    SPICELIB Version 1.0.0, 19-JUL-2005 (NJB)
C
C-&

C$ Index_Entries
C
C     linear interpolation between quaternions
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      BRCKTD

C
C     Local variables
C
      DOUBLE PRECISION      ANGLE
      DOUBLE PRECISION      AXIS   ( 3 )
      DOUBLE PRECISION      INSTAR ( 0 : 3 )
      DOUBLE PRECISION      INTANG
      DOUBLE PRECISION      Q      ( 0 : 3 )
      DOUBLE PRECISION      QSCALE ( 0 : 3 )
      DOUBLE PRECISION      VMAG

C
C     Use discovery check-in.
C
C
C
C     Find the conjugate INSTAR of the input quaternion INIT.
C
      INSTAR(0) = INIT(0)

      CALL VMINUS ( INIT(1),  INSTAR(1) )

C
C     Find the quotient quaternion Q that maps INIT to FINAL.
C
      CALL QXQ ( FINAL, INSTAR, Q )

C
C     Extract the rotation angle from Q. Use arccosine for
C     speed, sacrificing some accuracy.
C
      ANGLE = 2.D0 * ACOS (  BRCKTD( Q(0), -1.D0, 1.D0 )  )

C
C     Create a quaternion QSCALE from the rotation axis of the quotient
C     and the scaled rotation angle.
C
      INTANG = FRAC * ANGLE / 2.D0

      QSCALE(0) = COS ( INTANG )

C
C     Get the unit vector parallel to the vector part of Q.
C     UNORM does exactly what we want here, because if the vector
C     part of Q is zero, the returned "unit" vector will be the
C     zero vector.
C
      CALL UNORM ( Q(1), AXIS, VMAG )

C
C     Form the vector part of QSCALE.
C
      CALL VSCL (  SIN ( INTANG ),  AXIS,  QSCALE(1) )

C
C     Apply QSCALE to INIT to produce the interpolated quaternion we
C     seek.
C
      CALL QXQ ( QSCALE, INIT, QINTRP )

      RETURN
      END


*> \brief \b CLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLAEV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
*       .. Scalar Arguments ..
*       REAL               CS1, RT1, RT2
*       COMPLEX            A, B, C, SN1
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
*>    [  A         B  ]
*>    [  CONJG(B)  C  ].
*> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
*> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
*> eigenvector for RT1, giving the decomposition
*>
*> [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
*> [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is COMPLEX
*>         The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX
*>         The (1,2) element and the conjugate of the (2,1) element of
*>         the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is COMPLEX
*>         The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*>          RT1 is REAL
*>         The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*>          RT2 is REAL
*>         The eigenvalue of smaller absolute value.
*> \endverbatim
*>
*> \param[out] CS1
*> \verbatim
*>          CS1 is REAL
*> \endverbatim
*>
*> \param[out] SN1
*> \verbatim
*>          SN1 is COMPLEX
*>         The vector (CS1, SN1) is a unit right eigenvector for RT1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complexOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  RT1 is accurate to a few ulps barring over/underflow.
*>
*>  RT2 may be inaccurate if there is massive cancellation in the
*>  determinant A*C-B*B; higher precision or correctly rounded or
*>  correctly truncated arithmetic would be needed to compute RT2
*>  accurately in all cases.
*>
*>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
*>
*>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
*>  Underflow is harmless if the input data is 0 or exceeds
*>     underflow_threshold / macheps.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      REAL               CS1, RT1, RT2
      COMPLEX            A, B, C, SN1
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      REAL               T
      COMPLEX            W
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLAEV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, CONJG, REAL
*     ..
*     .. Executable Statements ..
*
      IF( ABS( B ).EQ.ZERO ) THEN
         W = ONE
      ELSE
         W = CONJG( B ) / ABS( B )
      END IF
      CALL SLAEV2( REAL( A ), ABS( B ), REAL( C ), RT1, RT2, CS1, T )
      SN1 = W*T
      RETURN
*
*     End of CLAEV2
*
      END


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE ORDER_TRIA ( KORDER, SS_I, SS_J, HH_IJ )

! Calculates abscissa and weight coefficients for triangular integration for the PENTA element

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, MAX_ORDER_TRIA
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  ORDER_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO, SIXTH, THIRD, HALF, TWO

      USE ORDER_TRIA_USE_IFs
      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'ORDER_TRIA'

      INTEGER(LONG), INTENT(IN)       :: KORDER                ! Triangular integration order to use
      INTEGER(LONG)                   :: I                     ! DO loop index
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = ORDER_BEGEND

      REAL(DOUBLE) ,INTENT(OUT)       :: SS_I(MAX_ORDER_TRIA)  ! Triangular integration abscissa's
      REAL(DOUBLE) ,INTENT(OUT)       :: SS_J(MAX_ORDER_TRIA)  ! Triangular integration abscissa's
      REAL(DOUBLE) ,INTENT(OUT)       :: HH_IJ(MAX_ORDER_TRIA) ! Triangular integration weight coeffs
      REAL(DOUBLE) , PARAMETER        :: A1 = .0597158717D0    ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: A2 = .7974269853D0    ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: B1 = .4701420641D0    ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: B2 = .1012865073D0    ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: W1 = .1125D0          ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: W2 = .0661970763D0    ! Intermediate constant
      REAL(DOUBLE) , PARAMETER        :: W3 = .0629695902D0    ! Intermediate constant

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
      DO I=1,MAX_ORDER_TRIA
         SS_I(I)  = ZERO
         SS_J(I)  = ZERO
         HH_IJ(I) = ZERO
      ENDDO

      IF      (KORDER == 1) THEN

         SS_I(1) = THIRD    ;     SS_J(1) = THIRD    ;     HH_IJ(1) = HALF

      ELSE IF (KORDER == 3) THEN

         SS_I(1) = SIXTH    ;     SS_J(1) = TWO*THIRD;     HH_IJ(1) = SIXTH
         SS_I(2) = SIXTH    ;     SS_J(2) = SIXTH    ;     HH_IJ(2) = SIXTH
         SS_I(3) = TWO*THIRD;     SS_J(3) = SIXTH    ;     HH_IJ(3) = SIXTH

      ELSE IF (KORDER == 7) THEN

         SS_I(1) = THIRD;     SS_J(1) = THIRD;     HH_IJ(1) = W1
         SS_I(2) = A1   ;     SS_J(2) = B1   ;     HH_IJ(2) = W2
         SS_I(3) = B1   ;     SS_J(3) = A1   ;     HH_IJ(3) = W2
         SS_I(4) = B1   ;     SS_J(4) = B1   ;     HH_IJ(4) = W2
         SS_I(5) = A2   ;     SS_J(5) = B2   ;     HH_IJ(5) = W3
         SS_I(6) = B2   ;     SS_J(6) = A2   ;     HH_IJ(6) = W3
         SS_I(7) = B2   ;     SS_J(7) = B2   ;     HH_IJ(7) = W3

      ELSE

         WRITE(ERR,1931) SUBR_NAME, KORDER
         WRITE(F06,1931) SUBR_NAME, KORDER
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )                            ! Coding error, so quit

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1931 FORMAT(' *ERROR  1931: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' TRIANGULAR INTEGRATION ORDER MUST BE EITHER 1, 3 OR 7 BUT VALUE IS ',I8)

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

      END SUBROUTINE ORDER_TRIA


program array2
implicit none
real,dimension (10) :: x
real :: average,sum
integer ::i
print*, "the numbers are"
sum =0.0
do i = 1,10
read*, x(i)
sum = sum + x(i)
end do
average = sum /10
print*, "the average is ",average
print*,x

end program array2


C     LAST UPDATE 02/1/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE ROOTJ(N,XMAX,ROOTS,MAXRTS,NR)
      IMPLICIT NONE
C
C Purpose: Calculates the first NR roots of Jn out to XMAX or the first
C          MAXRTS roots if NR > MAXRTS.
C
C Calls   1: RTJNK
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C
C Arguments:
C
      INTEGER N,MAXRTS,NR
      REAL ROOTS(MAXRTS),XMAX
C
C External function:
C
      REAL RTJNK
      EXTERNAL RTJNK
C
C Local variables:
C
      INTEGER I
C-----------------------------------------------------------------------
      DO 10 I=1,MAXRTS
         ROOTS(I) = RTJNK(N,I)
         IF(ROOTS(I).GT.XMAX)THEN
            NR = I - 1
            RETURN
         ENDIF
 10   CONTINUE
      NR = I - 1
C
      RETURN
      END

C     LAST UPDATE 02/1/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION RTJNK(N,K)
      IMPLICIT NONE
C
C Purpose: Calculates the Kth root of Jn.
C
C Calls   1: RTSAFE
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      REAL XACC,PI
      PARAMETER(XACC=1.0E-04,PI=3.141592654)
C
C Arguments:
C
      INTEGER N,K
C
C Local variables:
C
      REAL K0
      INTEGER I
      REAL RTMP,X1,X2
C
C External functions:
C
      REAL RTSAFE,BESSD
      EXTERNAL RTSAFE,BESSD
C
C Common block variables:
C
      INTEGER NBESS
C
C Common blocks:
C
      COMMON /BORDER/NBESS
C
C Data:
C
      DATA K0 /2.40483/
C-----------------------------------------------------------------------
C
C========Find Kth roots of zero order
C
      RTMP = K0
      NBESS = 0
      DO 10 I=2,K
         X1 = RTMP + 0.5*PI
         X2 = X1 + PI
         RTMP = RTSAFE(BESSD,X1,X2,XACC)
 10   CONTINUE
C
C========Find all the intervening Kth roots
C
      DO 20 I=1,ABS(N)
         NBESS = I
         X1 = RTMP
         X2 = X1 + PI
         RTMP = RTSAFE(BESSD,X1,X2,XACC)
 20   CONTINUE
      RTJNK = RTMP
C
      RETURN
      END


! Check that parameters are correct intercepted.
! Constants with comma separations are commonly
! used, for instance Pi = 3._dp
subroutine foo(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 3._sp
  real(dp), parameter :: three_d = 3._dp
  integer(ii), parameter :: three_i = 3_ii
  integer(il), parameter :: three_l = 3_il
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine

subroutine foo_no(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 3.
  real(dp), parameter :: three_d = 3.
  integer(ii), parameter :: three_i = 3
  integer(il), parameter :: three_l = 3
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine

subroutine foo_sum(x)
  implicit none
  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: ii = selected_int_kind(9)
  integer, parameter :: il = selected_int_kind(18)
  real(dp), intent(inout) :: x
  dimension x(3)
  real(sp), parameter :: three_s = 2._sp + 1._sp
  real(dp), parameter :: three_d = 1._dp + 2._dp
  integer(ii), parameter :: three_i = 2_ii + 1_ii
  integer(il), parameter :: three_l = 1_il + 2_il
  x(1) = x(1) + x(2) * three_s * three_i + x(3) * three_d * three_l
  x(2) = x(2) * three_s
  x(3) = x(3) * three_l
  return
end subroutine


      SUBROUTINE COSFT(Y,N,ISIGN)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
      DIMENSION Y(N)
      THETA=3.14159265358979D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      SUM=Y(1)
      M=N/2
      DO 11 J=1,M-1
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
        Y1=0.5*(Y(J+1)+Y(N-J+1))
        Y2=(Y(J+1)-Y(N-J+1))
        Y(J+1)=Y1-WI*Y2
        Y(N-J+1)=Y1+WI*Y2
        SUM=SUM+WR*Y2
11    CONTINUE
      CALL REALFT(Y,M,+1)
      Y(2)=SUM
      DO 12 J=4,N,2
        SUM=SUM+Y(J)
        Y(J)=SUM
12    CONTINUE
      IF (ISIGN.EQ.-1) THEN
        EVEN=Y(1)
        ODD=Y(2)
        DO 13 I=3,N-1,2
          EVEN=EVEN+Y(I)
          ODD=ODD+Y(I+1)
13      CONTINUE
        ENF0=2.0*(EVEN-ODD)
        SUMO=Y(1)-ENF0
        SUME=(2.0*ODD/FLOAT(N))-SUMO
        Y(1)=0.5*ENF0
        Y(2)=Y(2)-SUME
        DO 14 I=3,N-1,2
          Y(I)=Y(I)-SUMO
          Y(I+1)=Y(I+1)-SUME
14      CONTINUE
      ENDIF
      RETURN
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mncosp : cocosp test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(10),y(10),w(10),sx(10),s2(10),t(20),c(20),e(20),wrk(550)
      integer iwrk(450)
      logical bind(20)
      integer i,ier,is,j,j3,kwrk,lwrk,m,maxbin,maxtr,n,n4,n6
      real sq
c  the absciss values of the data points.
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10)/0.25,
     * 0.5,0.75,1.25,1.75,2.25,2.75,3.25,6.25,12.25/
c  the ordinate values of the data points.
      data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10)/17.0,
     * 15.2,13.8,12.2,11.0,10.1,9.4,8.6,6.1,3.5/
c  m denotes the number of data points.
      m = 10
c  we set up the weights of the data points.
      do 10 i=1,m
         w(i) = 1.
  10  continue
c  we set up the dimension information.
      maxtr = 100
      maxbin = 10
      lwrk = 550
      kwrk = 450
c  we fetch the knots of the cubic spline
      n = 11
      n4 = n-4
      n6 = n-6
c  the interior knots
      t(5) = 1.6
      t(6) = 2.5
      t(7) = 6.0
c  the boundary knots
      do 20 i=1,4
        t(i) = x(1)
        t(i+7) = x(m)
  20  continue
c  loop for the different spline approximations
      do 500 is=1,3
         go to (110,130,150),is
c  a convex spline approximation
 110     write(6,900)
         do 120 j=1,n6
            e(j) = -1.
 120     continue
         go to 200
c  a concave spline approximation (a straight line)
 130     write(6,905)
         do 140 j=1,n6
            e(j) = 1.
 140     continue
         go to 200
c  no convexity/concavity constraints
 150     write(6,910)
         do 160 j=1,n6
            e(j) = 0.
 160     continue
c  we determine the spline approximation.
 200     call cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,
     *     bind,wrk,lwrk,iwrk,kwrk,ier)
c  printing of the results.
         write(6,915) ier
         write(6,920) sq
         write(6,925) n
         write(6,930)
         write(6,935) (t(i),i=1,n)
         write(6,940)
         do 300 j=1,n6
            j3 = j+3
            if(bind(j)) write(6,945) t(j3)
 300     continue
         write(6,950)
         write(6,955) (c(i),i=1,n4)
c  we evaluate the second order derivative of the spline.
         call splder(t,n,c,3,2,x,s2,m,wrk,ier)
         write(6,960)
         do 400 i=1,m
            write(6,965) i,x(i),y(i),sx(i),s2(i)
 400     continue
 500  continue
      stop
c  format statements
 900  format(28h0convex spline approximation)
 905  format(29h0concave spline approximation)
 910  format(35h0unconstrained spline approximation)
 915  format(16h error flag ier=,i2)
 920  format(1x,28hsum of squared residuals sq=,e10.3)
 925  format(1x,24htotal number of knots n=,i2)
 930  format(1x,21hposition of the knots)
 935  format(5x,8f7.2)
 940  format(1x,24hthe knots where s''(x)=0)
 945  format(5x,f7.2)
 950  format(1x,21hb-spline coefficients)
 955  format(5x,4f12.4)
 960  format(3h0 i,6x,4hx(i),5x,4hy(i),4x,7hs(x(i)),3x,9hs''(x(i)))
 965  format(1x,i2,5x,f5.2,5x,f4.1,5x,f5.2,5x,f5.2)
      end


      REAL*8 FUNCTION PERIOD(GRAVMU,SCPOS,SCVEL)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE COMPUTES THE ORBITAL PERIOD OF A SATELLITE GIVEN THE
C POSITION AND VELOCITY VECTOR.
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C GRAVMU    1  R*8   I  GRAVITATIONAL COEFFICIENT IN KM**3/SEC**2.
C
C                       IF ZERO OR NEGATIVE, THE EARTH CENTRAL BODY TERM
C                       IS USED. THE VALUE IS OBTAINED FROM THE CONST
C                       ROUTINE.
C
C SCPOS     3  R*8   I  THE S/C POSITION VECTOR. IN KM.
C
C                       NOTE ON SCPOS AND SCVEL:
C
C                         MOTION IS ASSUMED TO BE CIRCULAR OR ELLIPTICAL
C                         ABOUT THE BODY FOR WHICH GRAVMU IS GIVEN. THE
C                         FUNDAMENTAL PLANE AND PRINCIPAL DIRECTION MAY
C                         BE ANY CONVENIENT SYSTEM. THE ORIGIN IS THE
C                         BODY ABOUT WHICH MOTION OCCURS.
C
C SCVEL     3  R*8   I  THE S/C VELOCITY VECTOR. IN KM/SEC.
C
C PERIOD    1  R*8   O  THE FUNCTION VALUE RETURNED. THIS IS THE ORBITAL
C                       PERIOD IN SECONDS.
C
C***********************************************************************
C
C BY C PETRUZZO, 11/83
C    MODIFIED.......
C
C***********************************************************************
C
      REAL*8 GRAVMU,SCPOS(3),SCVEL(3),ELEMS(6)
      REAL*8 TWOPI/ 6.283185307179586D0 /
C
C SOURCE OF EQUATIONS: ORBITAL FLIGHT HANDBOOK, PART 1, PAGE III-24,
C     EQN 4-1.  THE HANDBOOK WAS DONE BY THE MARTIN COMPANY FOR MSFC.
C
      VMU = GRAVMU
      IF(GRAVMU.LE.0.D0) VMU = CONST(56)
C
      R = DSQRT( SCPOS(1)**2 + SCPOS(2)**2 + SCPOS(3)**2 )
      VSQ =      SCVEL(1)**2 + SCVEL(2)**2 + SCVEL(3)**2
C
      SMA = R / (2.D0 - (R*VSQ/VMU) )
C
      PERIOD = TWOPI * SMA * DSQRT(SMA/VMU)
C
      RETURN
      END


SUBROUTINE p51(input_file,output_file)
!-------------------------------------------------------------------------
! Program 5.1 Plane or axisymmetric strain analysis of an elastic solid
!             using 3-, 6-, 10- or 15-node right-angled triangles or
!             4-, 8- or 9-node rectangular quadrilaterals. Mesh numbered
!             in x(r)- or y(z)- direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=70),INTENT(IN) :: input_file
 CHARACTER(len=70),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,ndim=2,ndof,nels,neq,nip,   &
   nlen,nn,nod,nodof=2,nprops=2,np_types,nr,nst=3,nxe,nye
 REAL(iwp)::det,one=1.0_iwp,penalty=1.0e20_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element,dir,type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),dee(:,:),der(:,:),deriv(:,:), &
   eld(:),fun(:),gc(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),loads(:),      &
   points(:,:),prop(:,:),sigma(:),value(:),weights(:),x_coords(:),        &
   y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,element,nod,dir,nxe,nye,nip,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 !ndof: number of degrees of freedom per element
 !nodof: number of degrees of freedom per node
 ndof=nod*nodof
 IF(type_2d=='axisymmetric')nst=4
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof),g_coord(ndim,nn),fun(nod),&
   coord(nod,ndim),jac(ndim,ndim),g_num(nod,nels),der(ndim,nod),          &
   deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),eld(ndof),weights(nip),    &
   g_g(ndof,nels),prop(nprops,np_types),num(nod),x_coords(nxe+1),         &
   y_coords(nye+1),etype(nels),gc(ndim),dee(nst,nst),sigma(nst))
 READ(10,*)prop
 etype=1
 IF(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(loads(0:neq),kdiag(neq))
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------element stiffness integration and assembly--------
 CALL sample(element,points,weights)
 kv=zero
 gc=one
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   int_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     IF(type_2d=='axisymmetric')THEN
       gc=MATMUL(fun,coord)
       bee(4,1:ndof-1:2)=fun(:)/gc(1)
     END IF
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)*gc(1)
   END DO int_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),                   &
     value(fixed_freedoms),no(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 IF(type_2d=='axisymmetric')THEN
   WRITE(11,'(/A)')"  Node   r-disp      z-disp"
 ELSE
   WRITE(11,'(/A)')"  Node   x-disp      y-disp"
 END IF
 DO k=1,nn
   WRITE(11,'(I5,2E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------recover stresses at nip integrating points--------
 nip=1
 DEALLOCATE(points,weights)
 ALLOCATE(points(nip,ndim),weights(nip))
 CALL sample(element,points,weights)
 WRITE(11,'(/A,I2,A)')" The integration point (nip=",nip,") stresses are:"
 IF(type_2d=='axisymmetric')THEN
   WRITE(11,'(A,A)')" Element r-coord     z-coord",                       &
   "     sig_r       sig_z       tau_rz      sig_t"
 ELSE
   WRITE(11,'(A,A)')" Element x-coord     y-coord",                       &
   "     sig_x       sig_y       tau_xy"
 END IF
 elements_3: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   eld=loads(g)
   int_pts_2: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     gc=MATMUL(fun,coord)
     jac=MATMUL(der,coord)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     IF(type_2d=='axisymmetric')THEN
       gc=MATMUL(fun,coord)
       bee(4,1:ndof-1:2)=fun(:)/gc(1)
     END IF
     sigma=MATMUL(dee,MATMUL(bee,eld))
     WRITE(11,'(I5,6E12.4)')iel,gc,sigma
   END DO int_pts_2
 END DO elements_3
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p51


*DECK DWUPDT
      SUBROUTINE DWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN)
C***BEGIN PROLOGUE  DWUPDT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNLS1 and DNLS1E
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (RWUPDT-S, DWUPDT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an N by N upper triangular matrix R, this subroutine
C     computes the QR decomposition of the matrix formed when a row
C     is added to R. If the row is specified by the vector W, then
C     DWUPDT determines an orthogonal matrix Q such that when the
C     N+1 by N matrix composed of R augmented by W is premultiplied
C     by (Q TRANSPOSE), the resulting matrix is upper trapezoidal.
C     The orthogonal matrix Q is the product of N transformations
C
C           G(1)*G(2)* ... *G(N)
C
C     where G(I) is a Givens rotation in the (I,N+1) plane which
C     eliminates elements in the I-th plane. DWUPDT also
C     computes the product (Q TRANSPOSE)*C where C is the
C     (N+1)-vector (b,alpha). Q itself is not accumulated, rather
C     the information to recover the G rotations is supplied.
C
C     The subroutine statement is
C
C       SUBROUTINE DWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
C
C     where
C
C       N is a positive integer input variable set to the order of R.
C
C       R is an N by N array. On input the upper triangular part of
C         R must contain the matrix to be updated. On output R
C         contains the updated triangular matrix.
C
C       LDR is a positive integer input variable not less than N
C         which specifies the leading dimension of the array R.
C
C       W is an input array of length N which must contain the row
C         vector to be added to R.
C
C       B is an array of length N. On input B must contain the
C         first N elements of the vector C. On output B contains
C         the first N elements of the vector (Q TRANSPOSE)*C.
C
C       ALPHA is a variable. On input ALPHA must contain the
C         (N+1)-st element of the vector C. On output ALPHA contains
C         the (N+1)-st element of the vector (Q TRANSPOSE)*C.
C
C       COS is an output array of length N which contains the
C         cosines of the transforming Givens rotations.
C
C       SIN is an output array of length N which contains the
C         sines of the transforming Givens rotations.
C
C     **********
C
C***SEE ALSO  DNLS1, DNLS1E
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DWUPDT
      INTEGER N,LDR
      DOUBLE PRECISION ALPHA
      DOUBLE PRECISION R(LDR,*),W(*),B(*),COS(*),SIN(*)
      INTEGER I,J,JM1
      DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO
      SAVE ONE, P5, P25, ZERO
      DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/
C***FIRST EXECUTABLE STATEMENT  DWUPDT
      DO 60 J = 1, N
         ROWJ = W(J)
         JM1 = J - 1
C
C        APPLY THE PREVIOUS TRANSFORMATIONS TO
C        R(I,J), I=1,2,...,J-1, AND TO W(J).
C
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ
            ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ
            R(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J).
C
         COS(J) = ONE
         SIN(J) = ZERO
         IF (ROWJ .EQ. ZERO) GO TO 50
         IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30
            COTAN = R(J,J)/ROWJ
            SIN(J) = P5/SQRT(P25+P25*COTAN**2)
            COS(J) = SIN(J)*COTAN
            GO TO 40
   30    CONTINUE
            TAN = ROWJ/R(J,J)
            COS(J) = P5/SQRT(P25+P25*TAN**2)
            SIN(J) = COS(J)*TAN
   40    CONTINUE
C
C        APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA.
C
         R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ
         TEMP = COS(J)*B(J) + SIN(J)*ALPHA
         ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA
         B(J) = TEMP
   50    CONTINUE
   60    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE DWUPDT.
C
      END


      SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
     $                   SNV, CSQ, SNQ )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      LOGICAL            UPPER
      REAL               A1, A3, B1, B3, CSQ, CSU, CSV
      COMPLEX            A2, B2, SNQ, SNU, SNV
*     ..
*
*  Purpose
*  =======
*
*  CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such
*  that if ( UPPER ) then
*
*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
*                        ( 0  A3 )     ( x  x  )
*  and
*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
*                        ( 0  B3 )     ( x  x  )
*
*  or if ( .NOT.UPPER ) then
*
*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
*                        ( A2 A3 )     ( 0  x  )
*  and
*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
*                        ( B2 B3 )     ( 0  x  )
*  where
*
*    U = (     CSU      SNU ), V = (     CSV     SNV ),
*        ( -CONJG(SNU)  CSU )      ( -CONJG(SNV) CSV )
*
*    Q = (     CSQ      SNQ )
*        ( -CONJG(SNQ)  CSQ )
*
*  Z' denotes the conjugate transpose of Z.
*
*  The rows of the transformed A and B are parallel. Moreover, if the
*  input 2-by-2 matrix A is not zero, then the transformed (1,1) entry
*  of A is not zero. If the input matrices A and B are both not zero,
*  then the transformed (2,2) element of B is not zero, except when the
*  first rows of input A and B are parallel and the second rows are
*  zero.
*
*  Arguments
*  =========
*
*  UPPER   (input) LOGICAL
*          = .TRUE.: the input matrices A and B are upper triangular.
*          = .FALSE.: the input matrices A and B are lower triangular.
*
*  A1      (input) REAL
*  A2      (input) COMPLEX
*  A3      (input) REAL
*          On entry, A1, A2 and A3 are elements of the input 2-by-2
*          upper (lower) triangular matrix A.
*
*  B1      (input) REAL
*  B2      (input) COMPLEX
*  B3      (input) REAL
*          On entry, B1, B2 and B3 are elements of the input 2-by-2
*          upper (lower) triangular matrix B.
*
*  CSU     (output) REAL
*  SNU     (output) COMPLEX
*          The desired unitary matrix U.
*
*  CSV     (output) REAL
*  SNV     (output) COMPLEX
*          The desired unitary matrix V.
*
*  CSQ     (output) REAL
*  SNQ     (output) COMPLEX
*          The desired unitary matrix Q.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      REAL               A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
     $                   AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, SNL,
     $                   SNR, UA11R, UA22R, VB11R, VB22R
      COMPLEX            B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
     $                   VB12, VB21, VB22
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARTG, SLASV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, CONJG, REAL
*     ..
*     .. Statement Functions ..
      REAL               ABS1
*     ..
*     .. Statement Function definitions ..
      ABS1( T ) = ABS( REAL( T ) ) + ABS( AIMAG( T ) )
*     ..
*     .. Executable Statements ..
*
      IF( UPPER ) THEN
*
*        Input matrices A and B are upper triangular matrices
*
*        Form matrix C = A*adj(B) = ( a b )
*                                   ( 0 d )
*
         A = A1*B3
         D = A3*B1
         B = A2*B1 - A1*B2
         FB = ABS( B )
*
*        Transform complex 2-by-2 matrix C to real matrix by unitary
*        diagonal matrix diag(1,D1).
*
         D1 = ONE
         IF( FB.NE.ZERO )
     $      D1 = B / FB
*
*        The SVD of real 2 by 2 triangular C
*
*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
*
         CALL SLASV2( A, FB, D, S1, S2, SNR, CSR, SNL, CSL )
*
         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
     $        THEN
*
*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
*           and (1,2) element of |U|'*|A| and |V|'*|B|.
*
            UA11R = CSL*A1
            UA12 = CSL*A2 + D1*SNL*A3
*
            VB11R = CSR*B1
            VB12 = CSR*B2 + D1*SNR*B3
*
            AUA12 = ABS( CSL )*ABS1( A2 ) + ABS( SNL )*ABS( A3 )
            AVB12 = ABS( CSR )*ABS1( B2 ) + ABS( SNR )*ABS( B3 )
*
*           zero (1,2) elements of U'*A and V'*B
*
            IF( ( ABS( UA11R )+ABS1( UA12 ) ).EQ.ZERO ) THEN
               CALL CLARTG( -CMPLX( VB11R ), CONJG( VB12 ), CSQ, SNQ,
     $                      R )
            ELSE IF( ( ABS( VB11R )+ABS1( VB12 ) ).EQ.ZERO ) THEN
               CALL CLARTG( -CMPLX( UA11R ), CONJG( UA12 ), CSQ, SNQ,
     $                      R )
            ELSE IF( AUA12 / ( ABS( UA11R )+ABS1( UA12 ) ).LE.AVB12 /
     $               ( ABS( VB11R )+ABS1( VB12 ) ) ) THEN
               CALL CLARTG( -CMPLX( UA11R ), CONJG( UA12 ), CSQ, SNQ,
     $                      R )
            ELSE
               CALL CLARTG( -CMPLX( VB11R ), CONJG( VB12 ), CSQ, SNQ,
     $                      R )
            END IF
*
            CSU = CSL
            SNU = -D1*SNL
            CSV = CSR
            SNV = -D1*SNR
*
         ELSE
*
*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
*           and (2,2) element of |U|'*|A| and |V|'*|B|.
*
            UA21 = -CONJG( D1 )*SNL*A1
            UA22 = -CONJG( D1 )*SNL*A2 + CSL*A3
*
            VB21 = -CONJG( D1 )*SNR*B1
            VB22 = -CONJG( D1 )*SNR*B2 + CSR*B3
*
            AUA22 = ABS( SNL )*ABS1( A2 ) + ABS( CSL )*ABS( A3 )
            AVB22 = ABS( SNR )*ABS1( B2 ) + ABS( CSR )*ABS( B3 )
*
*           zero (2,2) elements of U'*A and V'*B, and then swap.
*
            IF( ( ABS1( UA21 )+ABS1( UA22 ) ).EQ.ZERO ) THEN
               CALL CLARTG( -CONJG( VB21 ), CONJG( VB22 ), CSQ, SNQ, R )
            ELSE IF( ( ABS1( VB21 )+ABS( VB22 ) ).EQ.ZERO ) THEN
               CALL CLARTG( -CONJG( UA21 ), CONJG( UA22 ), CSQ, SNQ, R )
            ELSE IF( AUA22 / ( ABS1( UA21 )+ABS1( UA22 ) ).LE.AVB22 /
     $               ( ABS1( VB21 )+ABS1( VB22 ) ) ) THEN
               CALL CLARTG( -CONJG( UA21 ), CONJG( UA22 ), CSQ, SNQ, R )
            ELSE
               CALL CLARTG( -CONJG( VB21 ), CONJG( VB22 ), CSQ, SNQ, R )
            END IF
*
            CSU = SNL
            SNU = D1*CSL
            CSV = SNR
            SNV = D1*CSR
*
         END IF
*
      ELSE
*
*        Input matrices A and B are lower triangular matrices
*
*        Form matrix C = A*adj(B) = ( a 0 )
*                                   ( c d )
*
         A = A1*B3
         D = A3*B1
         C = A2*B3 - A3*B2
         FC = ABS( C )
*
*        Transform complex 2-by-2 matrix C to real matrix by unitary
*        diagonal matrix diag(d1,1).
*
         D1 = ONE
         IF( FC.NE.ZERO )
     $      D1 = C / FC
*
*        The SVD of real 2 by 2 triangular C
*
*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
*
         CALL SLASV2( A, FC, D, S1, S2, SNR, CSR, SNL, CSL )
*
         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
     $        THEN
*
*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
*           and (2,1) element of |U|'*|A| and |V|'*|B|.
*
            UA21 = -D1*SNR*A1 + CSR*A2
            UA22R = CSR*A3
*
            VB21 = -D1*SNL*B1 + CSL*B2
            VB22R = CSL*B3
*
            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS1( A2 )
            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS1( B2 )
*
*           zero (2,1) elements of U'*A and V'*B.
*
            IF( ( ABS1( UA21 )+ABS( UA22R ) ).EQ.ZERO ) THEN
               CALL CLARTG( CMPLX( VB22R ), VB21, CSQ, SNQ, R )
            ELSE IF( ( ABS1( VB21 )+ABS( VB22R ) ).EQ.ZERO ) THEN
               CALL CLARTG( CMPLX( UA22R ), UA21, CSQ, SNQ, R )
            ELSE IF( AUA21 / ( ABS1( UA21 )+ABS( UA22R ) ).LE.AVB21 /
     $               ( ABS1( VB21 )+ABS( VB22R ) ) ) THEN
               CALL CLARTG( CMPLX( UA22R ), UA21, CSQ, SNQ, R )
            ELSE
               CALL CLARTG( CMPLX( VB22R ), VB21, CSQ, SNQ, R )
            END IF
*
            CSU = CSR
            SNU = -CONJG( D1 )*SNR
            CSV = CSL
            SNV = -CONJG( D1 )*SNL
*
         ELSE
*
*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
*           and (1,1) element of |U|'*|A| and |V|'*|B|.
*
            UA11 = CSR*A1 + CONJG( D1 )*SNR*A2
            UA12 = CONJG( D1 )*SNR*A3
*
            VB11 = CSL*B1 + CONJG( D1 )*SNL*B2
            VB12 = CONJG( D1 )*SNL*B3
*
            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS1( A2 )
            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS1( B2 )
*
*           zero (1,1) elements of U'*A and V'*B, and then swap.
*
            IF( ( ABS1( UA11 )+ABS1( UA12 ) ).EQ.ZERO ) THEN
               CALL CLARTG( VB12, VB11, CSQ, SNQ, R )
            ELSE IF( ( ABS1( VB11 )+ABS1( VB12 ) ).EQ.ZERO ) THEN
               CALL CLARTG( UA12, UA11, CSQ, SNQ, R )
            ELSE IF( AUA11 / ( ABS1( UA11 )+ABS1( UA12 ) ).LE.AVB11 /
     $               ( ABS1( VB11 )+ABS1( VB12 ) ) ) THEN
               CALL CLARTG( UA12, UA11, CSQ, SNQ, R )
            ELSE
               CALL CLARTG( VB12, VB11, CSQ, SNQ, R )
            END IF
*
            CSU = SNR
            SNU = CONJG( D1 )*CSR
            CSV = SNL
            SNV = CONJG( D1 )*CSL
*
         END IF
*
      END IF
*
      RETURN
*
*     End of CLAGS2
*
      END


      integer function get_eqvfac(neqv,fix_vtx,nvtx)

      integer, intent(in) ::
     &     nvtx,
     &     neqv(nvtx)
      logical, intent(in) ::
     &     fix_vtx(nvtx)

      integer ::
     &     ieqvfac, ivtx

      integer, external ::
     &     ifac

      ieqvfac = 1
      do ivtx = 1, nvtx
        if (fix_vtx(ivtx).or.neqv(ivtx).lt.0) cycle
        ieqvfac = ieqvfac*ifac(neqv(ivtx))
      end do

      get_eqvfac = ieqvfac

      return
      end


      subroutine exjlnl (z, l, jl, nl)

c     purpose:  to calculate the spherical bessel functions jl and nl
c               for l = 0 to 6  using exact analytic expression
c
c     arguments:
c       z = argument of jl and nl
c       l = integer order of spherical bessel function
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c            Note that this nl = abramowitz yl.
c
c       analytic expressions from abramowitz 10.1.11 and 10.1.12
c       recurrence relation to get analytic j4,n4  eqns 10.1.19-22 ala

      implicit double precision (a-h, o-z)

      complex*16 z, jl, nl

      complex*16 cosz, sinz

c     Exact formulae unstable for very small z, so use series
c     expansion there.  Limit of .3 chosen for 9 digit agreement.
      if (abs(z) .lt. 0.3)  then
         call bjnser (z, l, jl, nl, 0)
      else
c        use analytic formulae
         cosz = cos(z)
         sinz = sin(z)

         if (l .eq. 0)  then
            jl =  sinz / z
            nl = -cosz / z

         elseif (l .eq. 1)  then
            jl =  sinz/z**2 - cosz/z
            nl = -cosz/z**2 - sinz/z

         elseif (l .eq. 2)  then
            jl = ( 3/z**3 - 1/z)*sinz - 3*cosz/z**2
            nl = (-3/z**3 + 1/z)*cosz - 3*sinz/z**2

         elseif (l .eq. 3)  then
            jl = ( 15/z**4 - 6/z**2)*sinz + (-15/z**3 + 1/z)*cosz
            nl = (-15/z**4 + 6/z**2)*cosz + (-15/z**3 + 1/z)*sinz

         elseif (l .eq. 4)  then
            jl = ( 105/z**5 - 45/z**3 + 1/z )*sinz +
     1                ( -105/z**4 + 10/z**2 )*cosz
            nl = (-105/z**5 + 45/z**3 - 1/z )*cosz +
     1                ( -105/z**4 + 10/z**2 )*sinz

         elseif (l .eq. 5)  then
            jl = ( 945/z**6 - 420/z**4 + 15/z**2 )*sinz +
     1              ( -945/z**5 + 105/z**3 - 1/z )*cosz
            nl = (-945/z**6 + 420/z**4 - 15/z**2 )*cosz +
     1              ( -945/z**5 + 105/z**3 - 1/z )*sinz

         elseif (l .eq. 6)  then
            jl = ( 10395/z**7 - 4725/z**5 + 210/z**3 - 1/z )*sinz +
     1              ( -10395/z**6 + 1155/z**4 - 21/z**2 )*cosz
            nl = (-10395/z**7 + 4725/z**5 - 210/z**3 + 1/z )*cosz +
     1              ( -10395/z**6 + 1155/z**4 - 21/z**2 )*sinz

         else
            stop 'exjlnl, l out of range'
         endif
      endif

      return
      end


MODULE Riemann_zeta

! From CERNLIB, with permission.
! Code converted using TO_F90 by Alan Miller
! Date: 2002-02-27  Time: 16:11:48

! Author: K.S. Kolbig, 7 June 1992
! Revision 1.1.1.1  1996/04/01 15:02:00  mclareni
! Mathlib gen/C (C315)

! The Riemann Zeta function
! Reference:
! Cody, W.J., Hillstrom, K.E. & Thather, H.C., `Chebyshev approximations
! for the Riemann zeta function', Math. Comp., vol.25 (1971), 537-547.

! N.B. The value returned by the CERNLIB routine was (zeta - 1) when the
!      argument was > 1.  This version returns the value of zeta.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

CONTAINS

FUNCTION r_zeta(x) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: x
REAL (dp)              :: fn_val

REAL (dp), PARAMETER :: delta = 1.0D-13, z1 = 1.0_dp, hf = z1/2, th = z1/3,  &
                        pi = 3.14159265358979324_dp, pih = pi/2, pi2 = 2*pi

REAL (dp), PARAMETER :: p1(0:8) = (/ 1.28716812148244639D+10,  &
  1.37539693203702511D+10, 5.10665591836440610D+09, 8.56147100243331486D+08, &
  7.48361812438023298D+07, 4.86010658546188251D+06, 2.73957499022140609D+05, &
  4.63171084318342712D+03, 5.78758100409666066D+01 /)
REAL (dp), PARAMETER :: q1(0:8) = (/ 2.57433624296484624D+10,  &
  5.93816564867959016D+09, 9.00633037326123344D+08, 8.04253663428328989D+07, &
  5.60971175954192006D+06, 2.24743120289913752D+05, 7.57457890934153756D+03, &
 -2.37383578137377262D+01, 1.0_dp /)

REAL (dp), PARAMETER :: p2(0:8) = (/ -6.88197293216348954D+06,  &
  7.48218916305315972D+06, -2.07584504810211014D+06, 3.55302557096214295D+05, &
 -4.06706449551854889D+04, 3.19804864027146911D+03, -1.69820937033722853D+02, &
  5.61485842394289048D+00, -8.93888705926154944D-02 /)
REAL (dp), PARAMETER :: q2(0:8) = (/ -1.29725624934891554D+09,  &
 -9.48715407579907817D+08, -1.05496193474005203D+08, 4.67774488211993048D+06, &
  3.12936040573813534D+06, 4.59581803839305070D+05, 3.88176109610396834D+04,  &
  1.92561544834491423D+03, 5.12578125000000000D+01 /)

REAL (dp), PARAMETER :: p3(0:9) = (/ 1.66156480515774676D-11,  &
 -4.68068827660654529D-09, 5.83519727319147047D-07, -4.17644012643145602D-05, &
  1.85468422843597959D-03, -5.11288800220490241D-02, 8.10450231751100353D-01, &
 -5.69951948768478923D+00, 0.0_dp, 0.0_dp /)
REAL (dp), PARAMETER :: q3(0:9) = (/ -6.99562633519191655D-10,  &
 -1.77757961895149257D-08, -9.82231825734078036D-07, -2.84927282759096488D-05, &
 -5.81727909388048094D-04, -1.15848749169766586D-02, -1.28149124051978196D-01, &
 -1.11913057349097709D+00, -7.67928761604628813D-01,  1.0_dp /)

REAL (dp), PARAMETER :: p4(0:8) = (/ 1.03144877188859712D-15,  &
 -5.12584613964688241D-13, 1.12948794194873548D-10, -1.44234665373130952D-08, &
  1.16824676984458098D-06, -6.14975167990314806D-05, 2.05594677988830328D-03, &
 -3.99339429394668869D-02, 3.45234976736178457D-01 /)
REAL (dp), PARAMETER :: q4(0:8) = (/ 5.93959417288419050D-11,  &
 -6.04755359079991806D-09, 3.64680208668388563D-07, -1.29456905568011812D-05, &
  3.20189498470229250D-04, -5.07801557099994077D-03, 5.49628907881587266D-02, &
 -3.24517611155972419D-01, 1.0_dp /)

REAL (dp)  :: alfa, ap, aq, b0, b1, b2, f, h, t, v
INTEGER    :: ix, j

v = x
f = 1.0_dp
IF (x /= 0 .AND. x < hf) THEN
  ix = x - delta
  IF (ABS(ix-x) <= delta) THEN
    IF (MOD(-ix,2) == 0) THEN
      h = 0.0_dp
      GO TO 70
    ELSE
      v = 1.0_dp - x
      f = 2 * (-z1) ** ((1-ix)/2) * dgamma(v) / pi2 ** v
    END IF
  ELSE
    v = 1.0_dp - x
    f = 2 * SIN(pih*x) * dgamma(v) / pi2 ** v
  END IF
END IF

IF (x == 0) THEN
  h = -3 * hf
ELSE IF (x == 1) THEN
  fn_val = 0.0_dp
  WRITE(*, *) 'Riemanns ZETA(X) HAS POLE AT X = 1'
  RETURN
ELSE IF (v <= 5) THEN
  ap = p1(8)
  aq = q1(8)
  DO  j = 7, 0, -1
    ap = p1(j) + v * ap
    aq = q1(j) + v * aq
  END DO
  h = ap / (aq*(v-1)) - 1
ELSE IF (v <= 11) THEN
  t = th * (v-8)
  alfa = t + t
  b1 = 0
  b2 = 0
  DO  j = 8, 0, -1
    b0 = p2(j) + alfa * b1 - b2
    b2 = b1
    b1 = b0
  END DO
  h = b0 - t * b2
  b1 = 0
  b2 = 0
  DO  j = 8, 0, -1
    b0 = q2(j) + alfa * b1 - b2
    b2 = b1
    b1 = b0
  END DO
  h = h / (b0 - t*b2)
ELSE IF (v <= 25) THEN
  t = 1 / v
  ap = p3(7)
  DO  j = 6, 0, -1
    ap = p3(j) + t * ap
  END DO
  aq = q3(9)
  DO  j = 8, 0, -1
    aq = q3(j) + t * aq
  END DO
  h = hf ** (v - t*ap/aq)
ELSE IF (v <= 55) THEN
  t = 1 / v
  ap = p4(8)
  aq = q4(8)
  DO  j = 7, 0, -1
    ap = p4(j) + t * ap
    aq = q4(j) + t * aq
  END DO
  h = hf ** (v-t*ap/aq)
ELSE IF (v <= 90) THEN
  h = hf ** v + th ** v
ELSE
  h = hf ** v
END IF
IF (x < 1) h = f * (1 + h)

70 IF (x > 1.0_dp) THEN
   fn_val = 1.0_dp + h
ELSE
   fn_val = h
END IF

RETURN
END FUNCTION r_zeta

! $Log: gamma64.F,v $
! Revision 1.1.1.1  1996/04/01 15:01:54  mclareni
! Mathlib gen

FUNCTION dgamma(x) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: x
REAL (dp)              :: fn_val

REAL (dp), PARAMETER  :: c(0:15) = (/ 3.65738772508338244_dp,  &
   1.95754345666126827_dp, 0.33829711382616039_dp, 0.04208951276557549_dp,  &
   0.00428765048212909_dp, 0.00036521216929462_dp, 0.00002740064222642_dp,  &
   0.00000181240233365_dp, 0.00000010965775866_dp, 0.00000000598718405_dp,  &
   0.00000000030769081_dp, 0.00000000001431793_dp, 0.00000000000065109_dp,  &
   0.00000000000002596_dp, 0.00000000000000111_dp, 0.00000000000000004_dp /)
REAL (dp)  :: alfa, b0, b1, b2, f, h, u
INTEGER    :: i

u = x
IF (u <= 0) THEN
  WRITE(*, '(a, g13.5, a)') ' Argument value: ', u, ' <= 0 for routine DGAMMA'
  h = 0
  RETURN
END IF

f = 1
IF (u < 3) THEN
  DO  i = 1, INT(4-u)
    f = f / u
    u = u + 1
  END DO
ELSE
  DO  i = 1, INT(u-3)
    u = u - 1
    f = f * u
  END DO
END IF
h = u + u - 7
alfa = h + h
b1 = 0
b2 = 0
DO  i = 15, 0, -1
  b0 = c(i) + alfa * b1 - b2
  b2 = b1
  b1 = b0
END DO

fn_val = f * (b0 - h*b2)
RETURN
END FUNCTION dgamma

END MODULE Riemann_zeta

PROGRAM Test_Riemann_zeta
USE Riemann_zeta
IMPLICIT NONE

! Output the LHS of Table 23.3 (page 811) of Abramowitz & Stegun

INTEGER             :: n
REAL (dp)           :: zeta
CHARACTER (LEN=21)  :: text

DO n = 2, 42
  zeta = r_zeta( DBLE(n) )
  WRITE(text, '(f18.16)') zeta
  text = text(:7) // ' ' // text(8:12) // ' ' // text(13:17) // ' ' // text(18:18)
  WRITE(*, '(i3, "  ", a)') n, text
END DO

STOP
END PROGRAM Test_Riemann_zeta


module forced_interaction

  use core_lib, only : dp, random

  implicit none
  save

  private
  public :: forced_interaction_wr99
  public :: forced_interaction_baes16
  public :: baes16_xi
  public :: WR99, BAES16

  ! The optical depth at which we transition to approximating (1 - exp(-tau))
  ! by simply tau
  real(dp), parameter :: TAU_THRES = 1.e-7_dp
  real(dp) :: baes16_xi = 0.5_dp

  integer, parameter :: WR99=1, BAES16=2

contains

  subroutine forced_interaction_wr99(tau_escape, tau, weight)

    ! Simple forced first interaction from Wood & Reynolds, 1999, The
    ! Astrophysical Journal, 525, 799:
    !
    ! http://dx.doi.org/10.1086/307939
    !
    ! This changes the probability density function for tau from exp(-tau)
    ! defined between 0 and infinity to being a truncated decaying exponential
    ! going from 0 to tau_escape. The PDF is thus:
    !
    !
    ! PDF = exp(-tau) / (1 - exp(-tau_escape))
    !
    ! and the CDF is
    !
    ! CDF = (1 - exp(-tau)) / (1 - exp(-tau_escape))

    implicit none

    real(dp),intent(in) :: tau_escape
    real(dp),intent(out) :: tau, weight
    real(dp) :: xi, one_minus_exp

    call random(xi)

    if(tau_escape > TAU_THRES) then
      one_minus_exp = (1._dp - exp(-tau_escape))
    else
      one_minus_exp = tau_escape
    end if

    tau = -log(1._dp - xi * one_minus_exp)
    weight = one_minus_exp

  end subroutine forced_interaction_wr99

  subroutine forced_interaction_baes16(tau_escape, tau, weight)

    ! Forced first interaction with composite biasing from Baes et al. 2019,
    ! Astronomy and Astrophysics, 590, A55:
    !
    ! http://dx.doi.org/10.1086/307939
    !
    ! This changes the probability density function for tau from exp(-tau)
    ! defined between 0 and infinity to being a composite of a truncated
    ! decaying exponential and a constant. The PDF is thus:
    !
    ! PDF = (1 - xi) * exp(-tau) / (1 - exp(-tau_escape)) + xi / tau_escape
    !
    ! where eta is in the range [0:1], and the CDF is
    !
    ! CDF = (1 - xi) * (1 - exp(-tau)) / (1 - exp(-tau_escape)) + xi * tau / tau_escape
    !
    ! Note that the xi parameter here is different from the xi used to sample
    ! random numbers. For simplicity, we define:
    !
    ! alpha = (1 - xi) / (1 - exp(-tau_escape))
    ! beta = xi / tau_escape
    !
    ! so that the CDF becomes:
    !
    ! CDF = alpha * (1 - exp(-tau)) + beta * tau
    !
    ! Unfortunately, we cannot solve CDF = random number analytically for tau,
    ! so instead we solve this by searching the CDF by bisection.

    implicit none

    real(dp),intent(in) :: tau_escape
    real(dp),intent(out) :: tau, weight
    real(dp) :: alpha, beta, tau_min, tau_max, xi, xi_test, one_minus_exp
    integer :: i

    if(tau_escape > TAU_THRES) then
      one_minus_exp = 1._dp - exp(-tau_escape)
    else
      one_minus_exp = tau_escape
    end if

    ! Pre-define alpha and beta for convenience and performance
    alpha = (1._dp - baes16_xi) / one_minus_exp
    beta = baes16_xi / tau_escape

    ! Search tau by bisection - we know in advance it will be in the range
    ! 0 to tau_escape, so we use this as initial limits
    tau_min = 0._dp
    tau_max = tau_escape

    call random(xi)

    ! 50 iterations is enough to get a result to machine precision
    do i=1,60
       tau = 0.5_dp * (tau_min + tau_max)
       if (tau > TAU_THRES) then
         xi_test = alpha * (1._dp - exp(-tau)) + beta * tau
       else
         xi_test = alpha * tau + beta * tau
       end if
       if (xi_test > xi) then
          tau_max = tau
       else
          tau_min = tau
       end if
    end do

    tau = 0.5_dp * (tau_min + tau_max)

    weight = 1._dp / (alpha + beta * exp(tau))

  end subroutine forced_interaction_baes16

end module forced_interaction


module mod_cylindricalduct
    use mod_kinds,          only: rk, ik
    use mod_constants,      only: HALF, ZERO, ONE, TWO
    use type_point,         only: point_t
    use type_function,      only: function_t
    use mod_function,       only: create_function
    use mod_gridspace,      only: linspace
    use mod_rootfinding,    only: bisect
    implicit none

contains

    !>  Compute eigenvalues of cylindrical duct modes for a given azimuthal
    !!  mode order 'm'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/14/2016
    !!
    !!
    !---------------------------------------------------------------------------
    function compute_cylindricalduct_eigenvalues(m,nevalues) result(evalues)
        integer(ik),    intent(in)  :: m
        integer(ik),    intent(in)  :: nevalues

        real(rk), dimension(nevalues)   :: evalues
        real(rk), allocatable           :: xvals(:)
        real(rk)                        :: fnew, fold, xnew, xold
        type(point_t)                   :: x
        integer(ik)                     :: ieig, ix
        class(function_t), allocatable  :: efcn

        !
        ! Create eigenfunction and set 'm'
        !
        call create_function(efcn,'cylindricalduct_eigenfunction')
        call efcn%set_option('m',real(m,rk))

        !
        ! Initialize values
        !
        evalues = ZERO
        call x%set(ZERO,ZERO,ZERO)

        !
        ! Numerically compute each eigen value
        !
        do ieig = 1,nevalues

            !
            ! Eigenvalue for (0,1) is ZERO. Bisection
            ! wouldn't find this because iteration starts
            ! after 0.
            !
            if ( m == 0 ) then
                if ( ieig == 1 ) then
                    evalues(ieig) = ZERO
                    exit
                end if
            end if

            !
            ! Get discretization values to try
            !
            if (ieig == 1) then
                ! Start from the beginning of the function
                xvals = linspace(0.1_rk,100._rk,1000)
            else
                ! Start after the previous zero
                xvals = linspace(evalues(ieig-1)+0.1,100._rk,10000)
            end if

            !
            ! Iterate through xvals and look for sign change
            !
            do ix = 1,size(xvals)
                x%c1_ = xvals(ix)
                fnew = efcn%compute(ZERO,x)
                xnew = xvals(ix)

                if (ix > 1) then
                    ! Test for sign change
                    if ( int(sign(ONE,fnew)) /= int(sign(ONE,fold)) ) then
                        ! Sign changed, so start bisection to find root.
                        evalues(ieig) = bisect(efcn, xold, xnew)
                        exit
                    else
                        fold = fnew
                        xold = xnew
                    end if
                else
                    fold = fnew
                    xold = xnew
                end if

            end do

        end do

    end function compute_cylindricalduct_eigenvalues
    !***************************************************************************

    !>  Return the value of a specified cylindrical duct mode.
    !!
    !!  For a specified azimuthal mode(m), and the eigenvalue of an associated
    !!  radial mode(alpha), compute the value of the mode at radial location(r),
    !!  bounded by the outer wall(rmax)
    !!
    !!  The mode values are normalized by N such that:
    !!
    !!  \f$ \int_0^1 N_{m \mu}^2 J(\alpha_{m \mu})^2 r dr = 1 \f$
    !!
    !!  This is outlined in the document:
    !!  "Fundamentals of Duct Acoustics" by Sjoerd W. Rienstra
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/14/2016
    !!
    !----------------------------------------------------------------------------
    impure elemental function compute_cylindricalduct_mode(m,alpha,r,rmax) result(val)
        integer(ik),    intent(in)  :: m
        real(rk),       intent(in)  :: alpha
        real(rk),       intent(in)  :: r
        real(rk),       intent(in)  :: rmax

        real(rk)    :: val, normalization

        ! Compute value of mode at location 'r'
        val = bessel_jn(m,alpha*r/rmax)

        ! Compute normalization
        if ( m == 0 ) then
            normalization = sqrt(TWO)
        else
            normalization = sqrt(TWO)/(bessel_jn(m,alpha)*sqrt(ONE - (real(m,rk)**TWO)/alpha**TWO))
        end if

        ! Apply normalization
        val = val*normalization

    end function compute_cylindricalduct_mode
    !*****************************************************************************

end module mod_cylindricalduct


!! This module makes a bimodal distribution using two maxwellians
!! one maxwellian on the left and another on the right and some sort of linear? switching in between...
!! IN 3D in velocity space and 1D in physical space...

!DIMENSIONLESS SEE NOTES FOR THE REDUCTION FORMULAS
module DGV_distributions_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.

implicit none
   interface maxwelveldist
     module procedure maxwelveldist, maxwelveldist_T_vector, maxwelveldist_u_vectors, &
                                     maxwelveldist_T_vector_u_vectors
   end interface

   interface ESBGK
     module procedure ESBGK_f0
   end interface

!!!!!!!!!!!!! parameters and global variables
real (DP), parameter, private :: pi25DT = 3.141592653589793238462643d0
!!!!!!!!!!

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! maxwelveldist (T,u_0,n,u) result (y)
!
! This function evauates the 3D velocity dimensionless maxwellian equilibrium distribution with given temperature and average velocity
! Temperature and average velocity can be arrays (corresponding to different points in x variable
!
! This function evaluates
! f_{M}(t,x,u)=(\pi T(t,x))^{-1/2} \exp(-\frac{(u-\bar{u})^2}{2RT})
!
! This is a reloadable function
!!!!!!!!!!!!!!!!!!!!!!!
!
! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0,v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), dimension (:), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T),size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
   integer (I4B) :: i ! local counter
!!!
beta=sqrt(pi25DT*T)*(pi25DT*T)
do i=1,size(u)
y(:,i) = n*exp(-((u(i)-u_0)*(u(i)-u_0)+(v(i)-v_0)*(v(i)-v_0)+&
                  (w(i)-w_0)*(w(i)-w_0))/max(T,0.0000001_DP))/beta
end do
end function maxwelveldist_T_vector_u_vectors

! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0, v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_T_vector

! this is the copy when T is scalar and u is vector
function maxwelveldist_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (scalar)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), dimension (:), intent (in) :: u,v,w    ! values of the velocity variable
   real (DP), dimension (size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_u_vectors

! this is the copy when both T and u are scalars
function maxwelveldist (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP)  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ESBGK_f0
!
! This function evauates the 3D ES-BGK equilibrium distribution with given temperature and average velocity.
! Note that the parameters are dependent on time and velocity but not in the spacial variable x
!
! This function evaluates
! f_0(t,u)=\frac{n(t)}{\sqrt{(\pi^3 det(\mathbb{T})}} \exp(-c'\mathbb{T}c)
!
!!!!!!!!!!!!!!!!!!!!!!!

function ESBGK_f0 (TensorInv,Determinant,n,u_0,v_0,w_0,nodes_u,nodes_v,nodes_w) result (f0)
! Evaluate f0 for ESBGK
real (DP), dimension(3,3), intent (in) :: TensorInv ! The inverse of the tensor matrix
real (DP), intent (in) :: u_0, v_0, w_0 ! These are the bulk velocities
real (DP), intent (in) :: Determinant ! This is the Determinant of the Tensor matrix
real (DP), intent (in) :: n ! this is the number density
real (DP), dimension(:), intent (in) :: nodes_u,nodes_v,nodes_w ! These are the velocity nodes
integer (I4B) :: Unodes ! the number of nodes in velocity space
real (DP), dimension(3) :: Left, c ! c-v vector
real (DP), parameter :: PI25DT = 3.141592653589793238462643d0
integer :: loc_alloc_stat
real (DP), dimension (:), allocatable  :: Prod ! This is the component that goes into the argument of the exponent
real (DP), dimension (1:size(nodes_u,1)) :: f0 ! result -- the ES-BGK distribution function
!real (DP), dimension(1:size(nodes_u,1)) :: nodes_cu, nodes_cv, nodes_cw
integer (I4B) :: i,j,k ! these are local counters

Unodes = size(nodes_U)   !  Get the number of elements of each of the nodes

allocate (Prod(1:size(nodes_u,1)), stat=loc_alloc_stat)
if (loc_alloc_stat >0) then
 print *, "ESBGK_f0: Allocation error for variables (Prod)"
 stop
end if

! from here, the component in the exponent's argument is computed

do i=1,Unodes
   ! c = \vec{u} - \vec{bar{u}}
   c(1) = nodes_u(i) - u_0
   c(2) = nodes_v(i) - v_0
   c(3) = nodes_w(i) - w_0

   ! used as part of the left operation (i.e. c'*TensorInv)
   Left(1) = c(1)*TensorInv(1,1) + c(2)*TensorInv(2,1) + c(3)*TensorInv(3,1)
   Left(2) = c(1)*TensorInv(1,2) + c(2)*TensorInv(2,2) + c(3)*TensorInv(3,2)
   Left(3) = c(1)*TensorInv(1,3) + c(2)*TensorInv(2,3) + c(3)*TensorInv(3,3)

   Prod(i) = Left(1)*c(1) + Left(2)*c(2) + Left(3)*c(3)! final computation of c'*TensorInv*c
end do

f0 = n/sqrt((PI25DT)**3*Determinant) * exp(-Prod)

deallocate (Prod)

end function ESBGK_f0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Shakhov_f0
!
! This function evauates the dimensionless 3D Shakhov equilibrium distribution function
! with given temperature and average velocity and the
! give Prandtl number.
!
!Note that the parameters are dependent on time and velocity but not in the spacial variable x
!
! This function evaluates
! f_0(t,u)=f_{M}(t,u)(1+(4/5)(1-Pr)S_{a}c^{a}(c_{a}c^{a}-5/2)) where c_a=(u_a-\bar{u}_a)/\sqrt{T}
! S_a=q_{a}/(nT^{3/2}), q_{a} = \int f (u_{a}-\bar(u)_{a})|u-\bar{u}|^2 du
!
!!!!!!!!!!!!!!!!!!!!!!!

function Shakhov_f0 (alpha,n,u_0,v_0,w_0,T,S_u,S_v,S_w,nodes_u,nodes_v,nodes_w) result (f0)
! Evaluate f0 for Shakhov model
real (DP), intent (in) :: alpha ! the Prandtl number
real (DP), intent (in) :: T ! This is the temperature of the local maxwellian
real (DP), intent (in) :: n ! this is the number density
real (DP), intent (in) :: u_0, v_0, w_0 ! These are the bulk velocities of the local maxwellian
real (DP), dimension(:), intent (in) :: S_u,S_v,S_w ! These are the components of the vector S in the shakov model

real (DP), dimension(:), intent (in) :: nodes_u,nodes_v,nodes_w ! These are the velocity nodes
real (DP), dimension (1:size(nodes_u,1)) :: f0 ! the Shakhov distribution function -- the result
!
!
real (DP), parameter :: PI25DT = 3.141592653589793238462643d0
real (DP), dimension (:), allocatable :: ShCorr,c_u, c_v, c_w! This are useful arrays,
integer (I4B) :: i,j,k,loc_alloc_stat ! these are local counters

allocate (ShCorr(1:size(nodes_u,1)),c_u(1:size(nodes_u,1)),c_v(1:size(nodes_u,1)),&
                  c_w(1:size(nodes_u,1)), stat=loc_alloc_stat)
if (loc_alloc_stat >0) then
 print *, "Shakhov_f0: Allocation error for variables (ShCorr,c_u,c_v,c_w)"
 stop
end if

! first, we compute the components of vector c:
c_u = (nodes_u-u_0)/sqrt(T)
c_v = (nodes_v-v_0)/sqrt(T)
c_w = (nodes_w-w_0)/sqrt(T)
! Next we compute the Shakhov correction term
ShCorr = (S_u*c_u+S_v*c_v+S_w*c_w)*((c_u*c_u+c_v*c_v+c_w*c_w)-5.0_DP/2.0_DP)
ShCorr = (1+4.0_DP/5.0_DP*((-1)*alpha)/(1-alpha)*ShCorr)
!!!!!!!!
f0 = maxwelveldist(T,u_0,v_0,w_0,n,nodes_u,nodes_v,nodes_w)*ShCorr

deallocate (ShCorr,c_u,c_v,c_w)

end function Shakhov_f0

end module DGV_distributions_mod


      subroutine comppro(v,n1v,nrow,nv,x)
c---------------------------------------------------------------
c        projects vector x onto subspace perpendicular to
c  orthonormal basis vectors stored in array v. (i.e. its orthogonal
c  complement).
c
c  arguments-
c    v - array of containing orthonormal basis vectors defining the
c        subspace whose complement x is to be projected onto.
c        these vectors are assumed to be stored in the columns of v.
c    n1v-first dimension of v in calling program.
c    nrow-number of elements in the rows of v and x.
c    nv-number of vectors in v.  (i.e. number of columns in v)
c    x-vector to be projected.  it is overwritten on return by
c      the requested projection.
c
c  author   gary l. pavlis
c           geophysics program ak-50
c           university of washington
c           seattle, wa  98195
c
c  written   january 1983
c---------------------------------------------------------------------
      integer n1v,nrow,nv
      real v(n1v,nv),x(nrow)
      integer j
      real scale
      do 100 j=1,nv
           scale = sdot(nrow,v(1,j),1,x,1)
           call saxpy(nrow,-scale,v(1,j),1,x,1)
  100 continue
      return
      end

c $Id$


module elements

implicit none

double precision, parameter :: pi = 3.1415926535897931d0

contains

pure function fromrv(r, v, mu) result(ele)
    double precision, dimension(:), intent(in) :: r
    double precision, dimension(:), intent(in) :: v
    double precision, intent(in) :: mu
    double precision, dimension(6) :: ele

    double precision :: r_mag, v_mag, h_mag, n_mag, xi
    double precision, dimension(3) :: h, n, k, e

    r_mag = norm2(r)
    v_mag = norm2(v)
    h = cross(r,v)
    h_mag = norm2(h)
    k = [0d0, 0d0, 1d0]
    n = cross(k, h)
    n_mag = norm2(n)
    xi = v_mag**2/2 - mu/r_mag
    e = ((v_mag**2 - mu/r_mag)*r - v*dot_product(r,v))/mu
    ele(2) = norm2(e)
    if (ele(2) /= 1.0) then
        ele(1) = -mu/(2*xi)
    else
        ele(1) = h_mag**2/mu
    end if
    ele(3) = acos(h(3)/h_mag)
    ele(4) = acos(n(1)/n_mag)
    ele(5) = acos(dot_product(n,e)/(ele(2)*n_mag))
    ele(6) = acos(dot_product(e,r)/(ele(2)*r_mag))
    if (n(2) < 0) then
        ele(4) = 2*pi - ele(4)
    end if
    if (e(3) < 0) then
        ele(5) = 2*pi - ele(5)
    end if
    if (dot_product(r,v) < 0) then
        ele(6) = 2*pi - ele(6)
    end if
end function fromrv

pure function cross(a, b)
    double precision, dimension(:), intent(in) :: a
    double precision, dimension(:), intent(in) :: b
    double precision, dimension(3) :: cross

    cross(1) = a(2) * b(3) - a(3) * b(2)
    cross(2) = a(3) * b(1) - a(1) * b(3)
    cross(3) = a(1) * b(2) - a(2) * b(1)
end function cross

subroutine benchmark_elements(times)
    integer, intent(in) :: times

    double precision, dimension(3) :: r
    double precision, dimension(3) :: v
    double precision, dimension(6) :: el
    double precision, parameter :: mu = 3.986004418d5

    double precision :: current, rate
    integer(kind=8) :: start, finish, irate
    double precision :: total, best, worst
    integer :: i

    r = [8.59072560d+02, -4.13720368d+03, 5.29556871d+03]
    v = [7.37289205d+00, 2.08223573d+00, 4.39999794d-01]

    worst = -1d20
    best = 1d20
    total = 0d0
    call system_clock(count_rate=irate)
    rate = dble(irate)
    do i=1, times
        call system_clock(start)

        el = fromrv(r, v, mu)

        call system_clock(finish)
        current = (finish - start)/rate
        if (current < best .and. current > 0) then
            best = current
        end if
        if (current > worst) then
            worst = current
        end if
        total = total + current
    end do
    print *, total/times, best, worst
end subroutine benchmark_elements

end module elements


module global_integral_mod

use              fms_mod, only: mpp_pe, mpp_root_pe, &
                                write_version_number

use press_and_geopot_mod, only: half_level_pressures

use       transforms_mod, only: area_weighted_global_mean

use        constants_mod, only: grav

use      mpp_domains_mod, only: mpp_global_field

implicit none
private

public :: mass_weighted_global_integral

real :: global_sum_of_wts
logical :: entry_to_logfile_done=.false.
character(len=128), parameter :: version = '$Id: global_integral.f90,v 13.0 2006/03/28 21:17:51 fms Exp $'
character(len=128), parameter :: tagname = '$Name: latest $'

contains

!---------------------------------------------------------------------------------------------

function mass_weighted_global_integral(field, surf_press)

!  This function returns the mass weighted vertical integral of field,
!  area averaged over the globe. The units of the result are:
!  (units of field)*(Kg/meters**2)

real :: mass_weighted_global_integral
real, intent(in), dimension(:,:,:) :: field
real, intent(in), dimension(:,:)   :: surf_press
real, dimension(size(field,1), size(field,2), size(field,3)  ) :: dp
real, dimension(size(field,1), size(field,2), size(field,3)+1) :: p_half

real, dimension(size(field,1), size(field,2)) :: vert_integral

integer ::  k, num_levels

if(.not.entry_to_logfile_done) then
  call write_version_number(version, tagname)
  entry_to_logfile_done=.true.
endif

num_levels = size(field,3)
p_half= half_level_pressures(surf_press)
dp = p_half(:,:,2:num_levels+1) - p_half(:,:,1:num_levels)
vert_integral = 0.
do k=1,num_levels
  vert_integral = vert_integral + field(:,:,k)*dp(:,:,k)
enddo
mass_weighted_global_integral = area_weighted_global_mean(vert_integral)/grav

return
end function mass_weighted_global_integral
!---------------------------------------------------------------------------------------------
end module global_integral_mod


	subroutine tucspl (xa, ya, n, work, y2)
C
C  Compute the second derivative of YA at each point in the array.
C  This is the initialization needed in preparation for interpolating
C  using cubic splines by the subroutine TUISPL.  Input and output
C  are all double precision.
C
C  This routine was copied with slight modifications from the SPLINE
C  subroutine in Numerical Recipes by Press, Flannery, Teukolsky and
C  Vetterling.
C
C  N		i: number of elements in each array
C  XA		i: array of independent-variable values
C  YA		i: array of dependent-variable values
C  WORK		io: scratch array used for work space
C  Y2		o: second derivative of YA at each point
C
CH  Phil Hodge, 14-Apr-1988  Subroutine copied from Numerical Recipes SPLINE.
C
	integer n
	double precision xa(n), ya(n), work(n), y2(n)
C--
	integer i
	double precision p, sig

C  These values (and y2(n) = 0) are for a "natural" spline.
	y2(1) = 0.
	work(1) = 0.
C
C  This is the decomposition loop of the tridiagonal algorithm.
C  Y2 and WORK are used for temporary storage of the decomposed factors.
C
	do 10 i = 2, n-1
	    sig = (xa(i) - xa(i-1)) / (xa(i+1) - xa(i-1))
	    p = sig * y2(i-1) + 2.
	    y2(i) = (sig - 1.) / p
	    work(i) = (6. * ((ya(i+1) - ya(i)) / (xa(i+1) - xa(i))
     +			- (ya(i) - ya(i-1)) / (xa(i) - xa(i-1))) /
     +			(xa(i+1) - xa(i-1)) - sig * work(i-1)) / p
 10	continue

C					"natural" spline
	y2(n) = 0.
C
C  This is the backsubstitution loop of the tridiagonal algorithm.
C
	do 20 i = n-1, 1, -1
	    y2(i) = y2(i) * y2(i+1) + work(i)
 20	continue

	return
	end


*DECK HTRIDI
      SUBROUTINE HTRIDI (NM, N, AR, AI, D, E, E2, TAU)
C***BEGIN PROLOGUE  HTRIDI
C***PURPOSE  Reduce a complex Hermitian matrix to a real symmetric
C            tridiagonal matrix using unitary similarity
C            transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B1
C***TYPE      SINGLE PRECISION (HTRIDI-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of a complex analogue of
C     the ALGOL procedure TRED1, NUM. MATH. 11, 181-195(1968)
C     by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a COMPLEX HERMITIAN matrix
C     to a real symmetric tridiagonal matrix using
C     unitary similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR and AI, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
C          variable. N must be less than or equal to NM.
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the complex Hermitian input matrix.  Only the lower
C          triangle of the matrix need be supplied.  AR and AI are two-
C          dimensional REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
C
C     On OUTPUT
C
C        AR and AI contain some information about the unitary trans-
C          formations used in the reduction in the strict lower triangle
C          of AR and the full lower triangle of AI.  The rest of the
C          matrices are unaltered.
C
C        D contains the diagonal elements of the real symmetric
C          tridiagonal matrix.  D is a one-dimensional REAL array,
C          dimensioned D(N).
C
C        E contains the subdiagonal elements of the real tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2(1) is set to zero.  E2 may coincide with E if the squares
C          are not needed.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C        TAU contains further information about the transformations.
C          TAU is a one-dimensional REAL array, dimensioned TAU(2,N).
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HTRIDI
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL AR(NM,*),AI(NM,*),D(*),E(*),E2(*),TAU(2,*)
      REAL F,G,H,FI,GI,HH,SI,SCALE
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  HTRIDI
      TAU(1,N) = 1.0E0
      TAU(2,N) = 0.0E0
C
      DO 100 I = 1, N
  100 D(I) = AR(I,I)
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(AR(I,K)) + ABS(AI(I,K))
C
         IF (SCALE .NE. 0.0E0) GO TO 140
         TAU(1,L) = 1.0E0
         TAU(2,L) = 0.0E0
  130    E(I) = 0.0E0
         E2(I) = 0.0E0
         GO TO 290
C
  140    DO 150 K = 1, L
            AR(I,K) = AR(I,K) / SCALE
            AI(I,K) = AI(I,K) / SCALE
            H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         G = SQRT(H)
         E(I) = SCALE * G
         F = PYTHAG(AR(I,L),AI(I,L))
C     .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
         IF (F .EQ. 0.0E0) GO TO 160
         TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F
         SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F
         H = H + F * G
         G = 1.0E0 + G / F
         AR(I,L) = G * AR(I,L)
         AI(I,L) = G * AI(I,L)
         IF (L .EQ. 1) GO TO 270
         GO TO 170
  160    TAU(1,L) = -TAU(1,I)
         SI = TAU(2,I)
         AR(I,L) = G
  170    F = 0.0E0
C
         DO 240 J = 1, L
            G = 0.0E0
            GI = 0.0E0
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, J
               G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
               GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
  180       CONTINUE
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
               G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
               GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
  200       CONTINUE
C     .......... FORM ELEMENT OF P ..........
  220       E(J) = G / H
            TAU(2,J) = GI / H
            F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = AR(I,J)
            G = E(J) - HH * F
            E(J) = G
            FI = -AI(I,J)
            GI = TAU(2,J) - HH * FI
            TAU(2,J) = -GI
C
            DO 260 K = 1, J
               AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K)
     1                           + FI * TAU(2,K) + GI * AI(I,K)
               AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K)
     1                           - FI * E(K) - GI * AR(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
            AR(I,K) = SCALE * AR(I,K)
            AI(I,K) = SCALE * AI(I,K)
  280    CONTINUE
C
         TAU(2,L) = -SI
  290    HH = D(I)
         D(I) = AR(I,I)
         AR(I,I) = HH
         AI(I,I) = SCALE * SQRT(H)
  300 CONTINUE
C
      RETURN
      END


      SUBROUTINE area2d(x,area,vn,ntype)
!---------------------------------------------------
!***  calculates volume of a pyramid with a quad base (1GP scheme)
!---------------------------------------------------

      IMPLICIT NONE

      INTEGER(kind=4):: ntype
      REAL(kind=8):: area,x(2,2),vn(2)

      REAL(kind=8) :: x1(2)
      REAL (kind=8), PARAMETER  :: twopi=6.283185307179586

      X1(:) = X(:,2)-X(:,1)
      vn(1) = -x1(2)
      vn(2) =  x1(1)
      CALL vecuni(2,vn,area)
      IF(ntype == 3) area=area*twopi*(x(1,1)+x(1,2))/2d0

      END SUBROUTINE area2d


c=======================================================================
c
c     GENGAM
c
c     Gamma distribution generator
c
c     Generates random deviates from the Gamma distribution whose
c     density is
c
c          (A**R)/Gamma(R) * X**(R-1) * Exp(-A*X)
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION gengam(a, r)
c-----------------------------------------------------------------------
c
c     INPUT :
c      a : location parameter of Gamma distribution (a>0)         double
c      r : shape parameter of Gamma distribution (r>0)            double
c
c     Method - for details see:
c               (Case R >= 1.0)
c               Ahrens, J.H. and Dieter, U.
c               Generating Gamma Variates by a
c               Modified Rejection Technique.
c               Comm. ACM, 25,1 (Jan. 1982), 47 - 54.
c     Algorithm GD
c
c               (Case 0.0 < R < 1.0)
c               Ahrens, J.H. and Dieter, U.
c               Computer Methods for Sampling from Gamma,
c               Beta, Poisson and Binomial Distributions.
c               Computing, 12 (1974), 223-246/
c     Adapted algorithm GS.
c
c----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION a, r
c
c     external functions
      DOUBLE PRECISION sgamma
      EXTERNAL sgamma
c
c     executable statements
 10   gengam = sgamma(r)/a
c      gengam = gengam/a
      RETURN
      END