C$Procedure      STMP03 ( Stumpff functions 0 through 3 )

      SUBROUTINE STMP03 ( X, C0, C1, C2, C3 )

C$ Abstract
C
C     Compute the values of the Stumpff functions C_0 through C_3 at
C     a specified point.
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     None.
C
C$ Keywords
C
C     CONIC
C     MATH
C     UTILITY
C
C$ Declarations

      DOUBLE PRECISION      X
      DOUBLE PRECISION      C0
      DOUBLE PRECISION      C1
      DOUBLE PRECISION      C2
      DOUBLE PRECISION      C3

      INTEGER               TRUNC
      PARAMETER           ( TRUNC = 11   )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     X          I   Argument to each Stumpff function C_0 to C_3.
C     C0         O   Value of C_0(X)
C     C1         O   Value of C_1(X)
C     C2         O   Value of C_2(X)
C     C3         O   Value of C_3(X)
C     TRUNC      P   Number of terms needed in Maclaurin series for C_3.
C
C$ Detailed_Input
C
C     X          is the argument to use in each of the Stumpff functions
C                C_0, C_1, C_2, and C_3.
C
C$ Detailed_Output
C
C     C0         are the values of the Stumpff functions
C     C1         C_0(X), C_1(X), C_2(X), and C_3(X).
C     C2
C     C3
C
C$ Parameters
C
C     TRUNC     The Maclaurin series for C_3 and C_2 respectively are:
C
C                                      2     3                 k
C                         1     X     X     X              (-X)
C              C_3(X) =  --- - --- + --- - --- + . . . + ----------. . .
C                         3!    5!    7!    9!           (3 + 2*K)!
C
C               and
C
C                                      2     3                 k
C                         1     X     X     X              (-X)
C              C_2(X) =  --- - --- + --- - --- + . . . + ----------. . .
C                         2!    4!    6!    8!           (2 + 2*K)!
C
C               These series are used in the evaluation of C_3 and C_2.
C               Thus, it is necessary to make a decision about where to
C               truncate the series in our evaluation of C_3 and C_2.
C
C               TRUNC is used to tell this routine where to truncate
C               the Maclaurin series for C_3 and C_2.
C
C               The value of TRUNC for your machine  is the smallest
C               integer such that
C
C                                 1
C                   1.0D0  +  ----------        =  1.0D0
C                             (2*TRUNC)!
C
C               The following program will (if compiled and linked)
C               will produce the values of TRUNC for your machine.
C
C               INTEGER               TRUNC
C
C               DOUBLE PRECISION      DENOM
C               DOUBLE PRECISION      FACTR
C
C               DOUBLE PRECISION      X
C
C               DENOM = 2.0D0
C               FACTR = 2.0D0
C               TRUNC = 1
C
C               X      = 1.0D0 / DENOM
C
C               DO WHILE ( 1.0D0 + X .GT. 1.0D0 )
C                  DENOM = DENOM * (2.0D0+FACTR) * (1.0D0+FACTR)
C                  FACTR = FACTR +  2.0D0
C                  TRUNC = TRUNC +  1
C                  X     = 1.0D0 /  DENOM
C               END DO
C
C               WRITE (*,*) 'The value of TRUNC is: ', TRUNC
C
C               END
C
C$ Exceptions
C
C     1)  If the input value of X is not in the domain of values
C         for which the Stumpff functions can be computed, the error
C         SPICE(VALUEOUTOFRANGE) is signalled.
C
C         The range of valid inputs is from  -[ln(2) + ln(DPMAX)]**2
C         to DPMAX.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine computes the values of the Stumpff functions C_0,
C     C_1, C_2, and C_3 at the input X.
C
C     The Stumpff function C_k(X) for k = 0, 1, ... is given by the
C     series:
C
C                                 2        3                  m
C                1      X        X        X               (-X)
C     C_k(X) =  --- - ------ + ------ - ------ + . . . + ------- + . . .
C                k!   (k+2)!   (k+4)!   (k+6)!           (k+2m)!
C
C
C     These series converge for all real values of X.
C
C
C$ Examples
C
C      For positive X,
C
C         C_0(X)   =  COS ( DSQRT(X) )
C
C
C                     SIN ( DSQRT(X) )
C         C_1(X)   =  ---------------
C                           DSQRT(X)
C
C
C                     1 - COS ( DSQRT(X) )
C         C_2(X)   = ---------------------
C                            X
C
C
C
C                     1  -  SIN ( DSQRT(X) ) / DSQRT(X)
C         C_3(X)   =  ----------------------------------
C                               X
C
C      Thus the following block of code can be used to check this
C      routine for reasonableness:
C
C      INTEGER               I
C
C      DOUBLE PRECISION      X
C      DOUBLE PRECISION      ROOTX
C
C      DOUBLE PRECISION      TC0
C      DOUBLE PRECISION      TC1
C      DOUBLE PRECISION      TC2
C      DOUBLE PRECISION      TC3
C
C      DOUBLE PRECISION      C0
C      DOUBLE PRECISION      C1
C      DOUBLE PRECISION      C2
C      DOUBLE PRECISION      C3
C
C      DO I = 1, 10
C
C         X     = DBLE (I)
C         ROOTX = DSQRT(X)
C
C         TC0   = COS ( ROOTX )
C         TC1   = SIN ( ROOTX ) / ROOTX
C
C         TC2   = ( 1.0D0 - COS( ROOTX )         ) / X
C         TC3   = ( 1.0D0 - SIN( ROOTX ) / ROOTX ) / X
C
C         CALL STMP03 ( X, C0, C1, C2, C3 )
C
C         WRITE (*,*)
C         WRITE (*,*) 'Expected - Computed for X = ', X
C         WRITE (*,*)
C         WRITE (*,*) 'Delta C0 :', TC0 - C0
C         WRITE (*,*) 'Delta C1 :', TC1 - C1
C         WRITE (*,*) 'Delta C2 :', TC2 - C2
C         WRITE (*,*) 'Delta C3 :', TC3 - C3
C
C      END DO
C
C      END
C
C      You should expect all of the differences to be on the order of
C      the precision of the machine on which this program is executed.
C
C$ Restrictions
C
C      None.
C
C$ Literature_References
C
C     [1] `Fundamentals of Celestial Mechanics', Second Edition
C         by J.M.A. Danby;  Willman-Bell, Inc., P.O. Box 35025
C         Richmond Virginia;  pp 168-180
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     H.A. Neilan    (JPL)
C     W.L. Taber     (JPL)
C     B.V. Semenov   (JPL)
C
C$ Version
C
C-    SPICELIB Version 3.27.0, 08-APR-2014 (NJB)
C
C        Updated in-line documentation and cleaned up
C        code following changes made in version 3.21.0.
C
C-    SPICELIB Version 3.26.0, 10-MAR-2014 (BVS)
C
C        Updated for SUN-SOLARIS-64BIT-INTEL.
C
C-    SPICELIB Version 3.25.0, 10-MAR-2014 (BVS)
C
C        Updated for PC-LINUX-64BIT-IFORT.
C
C-    SPICELIB Version 3.24.0, 10-MAR-2014 (BVS)
C
C        Updated for PC-CYGWIN-GFORTRAN.
C
C-    SPICELIB Version 3.23.0, 10-MAR-2014 (BVS)
C
C        Updated for PC-CYGWIN-64BIT-GFORTRAN.
C
C-    SPICELIB Version 3.22.0, 10-MAR-2014 (BVS)
C
C        Updated for PC-CYGWIN-64BIT-GCC_C.
C
C-    SPICELIB Version 3.21.0, 09-APR-2012 (WLT)
C
C        Code was updated to correct execessive round-off
C        errors in the case where |X| > 1.
C
C-    SPICELIB Version 3.20.0, 13-MAY-2010 (BVS)
C
C        Updated for SUN-SOLARIS-INTEL.
C
C-    SPICELIB Version 3.19.0, 13-MAY-2010 (BVS)
C
C        Updated for SUN-SOLARIS-INTEL-CC_C.
C
C-    SPICELIB Version 3.18.0, 13-MAY-2010 (BVS)
C
C        Updated for SUN-SOLARIS-INTEL-64BIT-CC_C.
C
C-    SPICELIB Version 3.17.0, 13-MAY-2010 (BVS)
C
C        Updated for SUN-SOLARIS-64BIT-NATIVE_C.
C
C-    SPICELIB Version 3.16.0, 13-MAY-2010 (BVS)
C
C        Updated for PC-WINDOWS-64BIT-IFORT.
C
C-    SPICELIB Version 3.15.0, 13-MAY-2010 (BVS)
C
C        Updated for PC-LINUX-64BIT-GFORTRAN.
C
C-    SPICELIB Version 3.14.0, 13-MAY-2010 (BVS)
C
C        Updated for PC-64BIT-MS_C.
C
C-    SPICELIB Version 3.13.0, 13-MAY-2010 (BVS)
C
C        Updated for MAC-OSX-64BIT-INTEL_C.
C
C-    SPICELIB Version 3.12.0, 13-MAY-2010 (BVS)
C
C        Updated for MAC-OSX-64BIT-IFORT.
C
C-    SPICELIB Version 3.11.0, 13-MAY-2010 (BVS)
C
C        Updated for MAC-OSX-64BIT-GFORTRAN.
C
C-    SPICELIB Version 3.10.0, 18-MAR-2009 (BVS)
C
C        Updated for PC-LINUX-GFORTRAN.
C
C-    SPICELIB Version 3.9.0, 18-MAR-2009 (BVS)
C
C        Updated for MAC-OSX-GFORTRAN.
C
C-    SPICELIB Version 3.8.0, 19-FEB-2008 (BVS)
C
C        Updated for PC-LINUX-IFORT.
C
C-    SPICELIB Version 3.7.0, 14-NOV-2006 (BVS)
C
C        Updated for PC-LINUX-64BIT-GCC_C.
C
C-    SPICELIB Version 3.6.0, 14-NOV-2006 (BVS)
C
C        Updated for MAC-OSX-INTEL_C.
C
C-    SPICELIB Version 3.5.0, 14-NOV-2006 (BVS)
C
C        Updated for MAC-OSX-IFORT.
C
C-    SPICELIB Version 3.4.0, 14-NOV-2006 (BVS)
C
C        Updated for PC-WINDOWS-IFORT.
C
C-    SPICELIB Version 3.3.0, 26-OCT-2005 (BVS)
C
C        Updated for SUN-SOLARIS-64BIT-GCC_C.
C
C-    SPICELIB Version 3.2.0, 03-JAN-2005 (BVS)
C
C        Updated for PC-CYGWIN_C.
C
C-    SPICELIB Version 3.1.0, 03-JAN-2005 (BVS)
C
C        Updated for PC-CYGWIN.
C
C-    SPICELIB Version 3.0.5, 17-JUL-2002 (BVS)
C
C        Added MAC-OSX environments.
C
C-    SPICELIB Version 3.0.4, 08-OCT-1999 (WLT)
C
C        The environment lines were expanded so that the supported
C        environments are now explicitely given.  New
C        environments are WIN-NT
C
C-    SPICELIB Version 3.0.3, 24-SEP-1999 (NJB)
C
C        CSPICE environments were added.  Some typos were corrected.
C
C-    SPICELIB Version 3.0.2, 28-JUL-1999 (WLT)
C
C        The environment lines were expanded so that the supported
C        environments are now explicitly given.  New
C        environments are PC-DIGITAL, SGI-O32 and SGI-N32.
C
C-    SPICELIB Version 3.0.1, 18-MAR-1999 (WLT)
C
C        The environment lines were expanded so that the supported
C        environments are now explicitly given.  Previously,
C        environments such as SUN-SUNOS and SUN-SOLARIS were implied
C        by the environment label SUN.
C
C-    SPICELIB Version 3.0.0, 08-APR-1998 (NJB)
C
C        Module was updated for the PC-LINUX platform.
C
C-    SPICELIB Version 2.0.0, 11-NOV-1993 (HAN)
C
C       The file was modified to include values for other platforms.
C       Also, the file was formatted for use by the program that
C       creates the environment specific source files.
C
C-    SPICELIB Version 1.0.0, 17-FEB-1992 (WLT)
C
C-&

C$ Index_Entries
C
C     Evaluate the first four Stumpff functions
C
C-&

C$ Revisions
C
C-    SPICELIB Version 3.27.0, 08-APR-2014 (NJB) (WLT)
C
C        In version 3.21.0, the routine was re-written to use the
C        standard trigonometric and hyperbolic trigonometric formulas
C        for the Stumpff functions for input arguments having magnitude
C        greater than or equal to 1. This was done to prevent loss of
C        accuracy for some input values.
C
C        In version 3.27.0, the code was cleaned up: unreachable code
C        was deleted, and comments were changed to match the updated
C        code.
C
C        The derivation of the argument mapping formulas has been
C        retained as an appendix in a comment section at the end of
C        this source file. These formulas may be used a future revision
C        of this routine.
C
C-    SPICELIB Version 3.0.0, 08-APR-1998 (NJB)
C
C        Module was updated for the PC-LINUX platform.
C
C-    SPICELIB Version 2.0.0, 11-NOV-1993 (HAN)
C
C       The file was modified to include values for other platforms.
C       Also, the file was formatted for use by the program that
C       creates the environment specific source files.
C
C-&

C
C     SPICELIB Functions
C
      DOUBLE PRECISION      DPMAX

C
C     Local Parameters
C

      DOUBLE PRECISION      HALF
      PARAMETER           ( HALF  = 1.0D0 / 2.0D0 )

      DOUBLE PRECISION      EIGHTH
      PARAMETER           ( EIGHTH = 1.0D0 / 8.0D0 )

C
C     The integers NPAIRS, LPAIR2, and LPAIR3 are used to declare
C     space for Maclaurin series coefficients and for determining how
C     many terms of these series to use in the computation of
C     C_2 and C_3.
C
C     Here's what is supposed to be true.
C
C        1/(TRUNC*2)!  + 1.0D0 = 1.0D0
C
C     using this machine's double precision arithmetic.
C
C     We will map the input X to a value y between -1 and 1 and then
C     construct the values of the functions at X from their values at y.
C     Since we will only evaluate the series expansion for C_2 and C_3
C     for values of y between -1 and 1, its easy to show that we don't
C     need to consider terms in the series whose coefficients have
C     magnitudes less than or equal 1/(2*TRUNC)! .
C
C     If the value of TRUNC is 10, then the series expansions for
C     C_2(y) and C_3(y) are can be truncated as shown here:
C
C                                   2             7       8
C              .    1      y       y             y       y
C       C_3(y) =   --- -  ---  +  ---  +  ... - ---  +  ---
C                   3!     5!      7!           17!     19!
C
C
C                 1        y         y            y           y
C              = ---( 1 - --- ( 1 - --- (...( 1- ----- ( 1 - ----- )...)
C                2*3      4*5       6*7          16*17       18*19
C
C
C
C
C              .    1      y       y             y       y
C       C_2(y) =   --- -  ---  +  ---  +  ... + ---  -  ---
C                   2!     4!      6!           16!     18!
C
C
C                 1        y         y            y           y
C              = ---( 1 - --- ( 1 - --- (...( 1- ----- ( 1 - ----- )...)
C                1*2      3*4       5*6          15*16       17*18
C
C     As is evident from the above, we are going to need the
C     "reciprocal pairs"
C
C       1/(1*2),  1/(2*3),  1/(3*4), 1/(4*5), ...
C
C     The number of such fractions be computed directly from
C     TRUNC. LPAIR3 and LPAIR2 indicate which of these pairs
C     (counting 1/(1*2) as the first) will be the last one needed in
C     the evaluation of C_2 and C_3.
C
      INTEGER               NPAIRS
      PARAMETER           ( NPAIRS = 2*TRUNC - 2 )

      INTEGER               LPAIR3
      PARAMETER           ( LPAIR3 = NPAIRS      )

      INTEGER               LPAIR2
      PARAMETER           ( LPAIR2 = NPAIRS - 1  )

C
C     Local variables
C
      DOUBLE PRECISION      LBOUND
      DOUBLE PRECISION      PAIRS  ( NPAIRS )
      DOUBLE PRECISION      Y
      DOUBLE PRECISION      Z

      INTEGER               I

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  FIRST
      SAVE                  LBOUND
      SAVE                  PAIRS

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

C
C     We are going to need the numbers
C
C        1/(2*3), 1/(3*4), 1/(4*5), ...
C
C     but we don't want to compute them every time this routine is
C     called.  So the first time this routine is called we compute
C     them and put them in the array PAIRS for use on subsequent
C     calls. (This could be done via parameters, but computing them
C     at run time seems to have a better chance of being
C     easily maintained.)
C
C     In addition we will need to compute the lower bound for which
C     C_0,...,C_3 can be computed.  This lower bound is computed by
C     noting that C_0 has the largest magnitude of all the Stumpff
C     functions over the domain from -infinity to -1.  Moreover, in this
C     range
C
C        C_0(X) = Cosh( SQRT(-X) )
C
C     Thus the range of X for which the Stumpff functions can be
C     computed is bounded below by the value of X for which
C
C        Cosh ( SQRT(-X) ) = DPMAX
C
C     Which implies the lower bound for valid inputs is at
C
C        X = - ( DLOG ( 2.0 ) + DLOG( DPMAX ) ) ** 2
C
C          = - ( DLOG ( 2*N ) + DLOG ( DPMAX/N  ) ) ** 2
C
C     We point out the second formulation of the bound just in case
C     your compiler can't handle the computation of DLOG ( DPMAX ).
C     If this unfortunate situation should arise, complain to the
C     company that produces your compiler and in the code below
C     compute LBOUND using the second form above with N equal to
C     some large power of 2 (say 2**20).
C
      IF ( FIRST ) THEN

         FIRST  = .FALSE.

         DO I = 1, NPAIRS
            PAIRS(I) = 1.0D0 / (DBLE(I)*DBLE(I+1))
         END DO

         Y      =   DLOG(2.0D0) + DLOG( DPMAX() )
         LBOUND = - Y*Y

      END IF

C
C     First we make sure that the input value of X is within the
C     range that we are confident we can use to compute the Stumpff
C     functions.
C
      IF ( X .LE. LBOUND ) THEN

         CALL CHKIN ( 'STMP03'                                     )
         CALL SETMSG( 'The input value of X must be greater than '
     .   //           '#.  The input value was #'                  )
         CALL ERRDP ( '#', LBOUND                                  )
         CALL ERRDP ( '#', X                                       )
         CALL SIGERR( 'SPICE(VALUEOUTOFRANGE)'                     )
         CALL CHKOUT( 'STMP03'                                     )
         RETURN

      END IF

C
C     From the definition of the Stumpff functions it can be seen that
C     C_0(X), C_1(X) are given by
C
C          COS ( DSQRT(X) )   and   SIN ( DSQRT(X) ) / DSQRT(X)
C
C     for positive X. Moreover, the series used to define them converges
C     for all real X.
C
C     These functions have a number of simple relationships that make
C     their computations practical.  Among these are:
C
C                         1
C          x*C_k+2(x) =  ---  -  C_k(x)
C                         k!
C
C
C
C                                 2
C           C_0(4x)   =  2*[ C_0(x) ]  -  1
C
C
C
C
C           C_1(4x)   =    C_1(x)*C_0(x)
C
C
C
C                                 2
C           C_2(4x)   =   [C_1(x)]  / 2
C
C
C
C
C           C_3(4x)   = [ C_2(x) + C_0(x)*C_3(x) ] / 4
C
C      These can be used to derive formulae for C_0(16x) ... C_3(16x)
C      that involve only C_0(x) ... C_3(x).  If we let
C
C                                      2
C                     Z        = C_0(x)  - 0.5
C
C      and
C
C                     W        = 2*C_0(x)*C_1(x)
C
C      then
C
C                                   2
C                     C_0(16x) = 8*Z  -  1
C
C
C                     C_1(16x) = W*Z
C
C
C                                 2
C                     C_2(16x) = W  / 8
C
C
C                                       2
C                                 C_1(x)  + Z*[C_2(x) + C_0(x)*C_3(x)]
C                     C_3(16x) =  ----------------------------------
C                                                  8
C
C
       IF ( X .LT. -1.D0 ) THEN

         Z  = SQRT(-X)
         C0 = COSH(Z)
         C1 = SINH(Z)/Z
         C2 = (1-C0)/X
         C3 = (1-C1)/X
         RETURN

      END IF

      IF ( X .GT. 1.D0 ) THEN

         Z  = SQRT(X)
         C0 = COS(Z)
         C1 = SIN(Z)/Z
         C2 = (1-C0)/X
         C3 = (1-C1)/X
         RETURN

      END IF

C
C     If the magnitude of X is less than or equal to 1, we compute
C     the function values directly from their power series
C     representations.
C
C
C     Compute C_3 of x :
C
C                                   2             7       8
C              .    1      x       x             x       x
C       C_3(x) =   --- -  ---  +  ---  +  ... - ---  +  ---
C                   3!     5!      7!           17!     19!
C
C
C                 1        x         x            x           x
C              = ---( 1 - --- ( 1 - --- (...( 1- ----- ( 1 - ----- )...)
C                2*3      4*5       6*7          16*17       18*19
C
C                 ^        ^         ^             ^           ^
C                 |        |         |             |           |
C                 |        |         |             |           |
C              PAIR(2)  PAIR(4)   PAIR(6)  ...  PAIR(16)    PAIR(18)
C
C     Assuming that we don't need to go beyond the term with 1/19!,
C     LPAIR3 will be 18.
C

      C3    = 1.0D0

      DO I  = LPAIR3, 4, -2
         C3 = 1.0D0 - X*PAIRS(I)*C3
      END DO

      C3    =           PAIRS(2)*C3

C
C     Compute C_2 of x  :
C
C        Here's how we do it.
C                                   2             7       8
C              .    1      x       x             x       x
C       C_2(x) =   --- -  ---  +  ---  +  ... + ---  -  ---
C                   2!     4!      6!           16!     18!
C
C
C                 1        x         x            x           x
C              = ---( 1 - --- ( 1 - --- (...( 1- ----- ( 1 - ----- )...)
C                1*2      3*4       5*6          15*16       17*18
C
C                 ^        ^         ^             ^           ^
C                 |        |         |             |           |
C                 |        |         |             |           |
C              PAIR(1)  PAIR(3)   PAIR(5)  ...  PAIR(15)    PAIR(17)
C
C     Assuming that we don't need to go beyond  the term with 1/18!,
C     LPAIR2 will be 17.
C
      C2    = 1.0D0

      DO I  = LPAIR2, 3, -2
         C2 = 1.0D0 - X*PAIRS(I)*C2
      END DO

      C2    =           PAIRS(1)*C2

C
C     Get C1 and C0 via the recursion formula:
C
C                         1
C          x*C_k+2(y) =  ---  -  C_k(x)
C                         k!
C
      C1 =  1.0D0 - X*C3
      C0 =  1.0D0 - X*C2

      RETURN
      END

C
C     Appendix
C     ========
C
C     The formulas below show how to relate Stumpff function values
C     at arbitrary points in the functions' domain to values at points
C     in the interval [-1, 1]. These formulas might be used to improve
C     accuracy of the computed function values. The original algorithm
C     of this routine attempted to do this, but was unsuccessful.
C
C
C     These functions have a number of simple relationships that make
C     their computations practical.  Among these are:
C
C                         1
C          x*C_k+2(x) =  ---  -  C_k(x)
C                         k!
C
C
C
C                                 2
C           C_0(4x)   =  2*[ C_0(x) ]  -  1
C
C
C
C
C           C_1(4x)   =    C_1(x)*C_0(x)
C
C
C
C                                 2
C           C_2(4x)   =   [C_1(x)]  / 2
C
C
C
C
C           C_3(4x)   = [ C_2(x) + C_0(x)*C_3(x) ] / 4
C
C      These can be used to derive formulae for C_0(16x) ... C_3(16x)
C      that involve only C_0(x) ... C_3(x).  If we let
C
C                                      2
C                     Z        = C_0(x)  - 0.5
C
C      and
C
C                     W        = 2*C_0(x)*C_1(x)
C
C      then
C
C                                   2
C                     C_0(16x) = 8*Z  -  1
C
C
C                     C_1(16x) = W*Z
C
C
C                                 2
C                     C_2(16x) = W  / 8
C
C
C                                       2
C                                 C_1(x)  + Z*[C_2(x) + C_0(x)*C_3(x)]
C                     C_3(16x) =  ----------------------------------
C                                                  8
C
C  [End]
C


! examples/Fortran/Lanczos.f90

module lanczos_module
  use ral_nlls_double, only : params_base_type
  implicit none

  integer, parameter :: wp = kind(0d0)

  type, extends(params_base_type) :: params_type
     real(wp), dimension(:), allocatable :: t ! The m data points t_i
     real(wp), dimension(:), allocatable :: y ! The m data points y_i
  end type params_type

contains

  subroutine eval_r(status, n, m, x, r, params)
    ! r_i = y_i - x_1 e^(-x_2 t_i) - x_3 e^(-x_4 t_i) - x_5 e^(-x_6 t_i)
    integer, intent(out) :: status
    integer, intent(in) :: n
    integer, intent(in) :: m
    real(wp), dimension(*), intent(in) :: x
    real(wp), dimension(*), intent(out) :: r
    class(params_base_type), intent(inout) :: params

    select type(params)
    type is(params_type)
       r(1:m) = params%y(:) &
            - x(1)*exp(-x(2)*params%t(:)) &
            - x(3)*exp(-x(4)*params%t(:)) &
            - x(5)*exp(-x(n)*params%t(:))
    end select

    status = 0 ! success

  end subroutine eval_r

  subroutine eval_J(status, n, m, x, J, params)
    integer, intent(out) :: status
    integer, intent(in) :: n
    integer, intent(in) :: m
    real(wp), dimension(*), intent(in) :: x
    real(wp), dimension(*), intent(out) :: J
    class(params_base_type), intent(inout) :: params

    select type(params)
    type is(params_type)
         J(    1:  m) = -exp(-x(2)*params%t(1:m))                     ! J_i1
         J(  m+1:2*m) = params%t(1:m) * x(1) * exp(-x(2)*params%t(1:m))! J_i2
         J(2*m+1:3*m) = -exp(-x(4)*params%t(1:m))                     ! J_i3
         J(3*m+1:4*m) = +params%t(1:m) * x(3) * exp(-x(4)*params%t(1:m))! J_i4
         J(4*m+1:5*m) = -exp(-x(6)*params%t(1:m))                     ! J_i5
         J(5*m+1:6*m) = +params%t(1:m) * x(5) * exp(-x(n)*params%t(1:m))! J_i6
    end select

    status = 0 ! Success
  end subroutine eval_J

  subroutine eval_HF(status, n, m, x, r, HF, params)
      integer, intent(out) :: status
      integer, intent(in) :: n
      integer, intent(in) :: m
      real(wp), dimension(*), intent(in) :: x
      real(wp), dimension(*), intent(in) :: r
      real(wp), dimension(*), intent(out) :: HF
      class(params_base_type), intent(inout) :: params

      HF(1:n*n) = 0.0
      select type(params)
      type is(params_type)
         HF(    2) = sum( r(1:m) * params%t(1:m) * exp(-x(2)*params%t(1:m)))  ! H_21
         HF(1*n+1) = HF(2)                                                     ! H_12
         HF(1*n+2) = sum(-r(1:m) * (params%t(1:m)**2) * x(1) * exp(-x(2)*params%t(1:m)))! H_22
         HF(2*n+4) = sum( r(1:m) * params%t(1:m) * exp(-x(4)*params%t(1:m)))  ! H_43
         HF(3*n+3) = HF(2*n+4)                                                 ! H_34
         HF(3*n+4) = sum(-r(1:m) * (params%t(1:m)**2) * x(3) * exp(-x(4)*params%t(1:m)))! H_44
         HF(4*n+6) = sum( r(1:m) * params%t(1:m) * exp(-x(6)*params%t(1:m)))  ! H_65
         HF(5*n+5) = HF(4*n + 6)                                                     ! H_56
         HF(5*n+6) = sum(-r(1:m) * (params%t(1:m)**2) * x(5) * exp(-x(6)*params%t(1:m)))! H_66
      end select

      status = 0 ! Success
    end subroutine eval_HF

    subroutine eval_HP(status, n, m, x, y, HP, params)
      integer, intent(out) :: status
      integer, intent(in) :: n
      integer, intent(in) :: m
      real(wp), dimension(*), intent(in) :: x
      real(wp), dimension(*), intent(in) :: y
      real(wp), dimension(*), intent(out) :: HP
      class(params_base_type), intent(inout) :: params

      integer :: i
      status = 0
      HP(1:n*m) = 0.0
      select type(params)
      type is (params_type)
         do i = 1, m
            HP((i-1)*n + 1) = params%t(i) * exp(-x(2)*params%t(i)) * y(2)
            HP((i-1)*n + 2) = params%t(i) * exp(-x(2)*params%t(i)) * y(1) - &
                 (params%t(i)**2) * x(1) * exp(-x(2)*params%t(i)) * y(2)
            HP((i-1)*n + 3) = params%t(i) * exp(-x(4)*params%t(i)) * y(4)
            HP((i-1)*n + 4) = params%t(i) * exp(-x(4)*params%t(i)) * y(3) - &
                 (params%t(i)**2) * x(3) * exp(-x(4)*params%t(i)) * y(4)
            HP((i-1)*n + 5) = params%t(i) * exp(-x(6)*params%t(i)) * y(6)
            HP((i-1)*n + 6) = params%t(i) * exp(-x(6)*params%t(i)) * y(5) - &
                 (params%t(i)**2) * x(5) * exp(-x(6)*params%t(i)) * y(6)
         end do
      end select

    end subroutine eval_HP

end module lanczos_module

program lanczos

  use ral_nlls_double
  use lanczos_module

  implicit none

  type(nlls_options) :: options
  type(nlls_inform) :: inform

  integer :: m,n
  real(wp), allocatable :: x(:)
  type(params_type) :: params
  real(wp) :: tic, toc

  ! data to be fitted
  m = 24
  allocate(params%t(m), params%y(m))
  ! Data from Lanczos 3
  params%t(:) = (/ 0.00000E+00, &
                   5.00000E-02, &
                   1.00000E-01, &
                   1.50000E-01, &
                   2.00000E-01, &
                   2.50000E-01, &
                   3.00000E-01, &
                   3.50000E-01, &
                   4.00000E-01, &
                   4.50000E-01, &
                   5.00000E-01, &
                   5.50000E-01, &
                   6.00000E-01, &
                   6.50000E-01, &
                   7.00000E-01, &
                   7.50000E-01, &
                   8.00000E-01, &
                   8.50000E-01, &
                   9.00000E-01, &
                   9.50000E-01, &
                   1.00000E+00, &
                   1.05000E+00, &
                   1.10000E+00, &
                   1.15000E+00 /)
  params%y(:) = (/ 2.5134E+00, &
                   2.0443E+00, &
                   1.6684E+00, &
                   1.3664E+00, &
                   1.1232E+00, &
                   0.9269E+00, &
                   0.7679E+00, &
                   0.6389E+00, &
                   0.5338E+00, &
                   0.4479E+00, &
                   0.3776E+00, &
                   0.3197E+00, &
                   0.2720E+00, &
                   0.2325E+00, &
                   0.1997E+00, &
                   0.1723E+00, &
                   0.1493E+00, &
                   0.1301E+00, &
                   0.1138E+00, &
                   0.1000E+00, &
                   0.0883E+00, &
                   0.0783E+00, &
                   0.0698E+00, &
                   0.0624E+00 /)

  ! call fitting routine
  n = 6
  allocate(x(n))
  x = (/ 1.2, 0.3, 5.6, 5.5, 6.5, 7.6 /) ! SP 1

  options%print_level = 4
  options%exact_second_derivatives = .true.
  options%model = 4
  options%nlls_method = 3
  options%use_ews_subproblem = .true.
  options%type_of_method = 2
  options%regularization_term = 1.0e-2
  options%regularization_power = 2.0
  options%reg_order = -1.0
  options%inner_method = 2
  options%maxit = 1000

  call cpu_time(tic)
  call nlls_solve(n,m,x,eval_r, eval_J, eval_HF, params, options, inform, eval_HP=eval_HP)
  if(inform%status.ne.0) then
     print *, "ral_nlls() returned with error flag ", inform%status
     stop
  endif
  call cpu_time(toc)

  ! Print result
  print *, "Found a local optimum at x = ", x
  print *, "Took ", inform%iter, " iterations"
  print *, "     ", inform%f_eval, " function evaluations"
  print *, "     ", inform%g_eval, " gradient evaluations"
  print *, "     ", inform%h_eval, " hessian evaluations"
  print *, "     ", toc-tic, " seconds"
end program lanczos


!============================================================
! <next few lines under version control, D O  N O T  E D I T>
! $Date$
! $Author$
! $Revision$
! $Id$
!============================================================

!============================================================
! a module to be used with spectral surface-based models.
!============================================================

!============================================================
MODULE spectral_mod

    implicit none

    real,    parameter :: pi = 4.0*atan(1.0)    ! pi = 3.14159265358979323846264338327950288419

    integer, parameter :: model = 1             ! 0:2D; 1:2sQG; 2:sQG-trop; 3:sQG-sfc; 4:HsQG
    real,    parameter :: dt    = 0.01          ! model time step

    integer, parameter :: ntims = 1001          ! number of model time steps
    integer, parameter :: iplot = 100           ! plots every iplot time steps
    integer, parameter :: imean = int(10.e3/dt) ! compute area mean every imean

    logical, parameter :: linear = .FALSE.      ! flag for linear advection (.TRUE./.FALSE.)
    logical, parameter :: trop   = .FALSE.      ! flag for tropopause geometry (.TRUE./.FALSE.)
    logical, parameter :: grow   = .FALSE.      ! grow a normal mode (.TRUE./.FALSE.)
    logical, parameter :: inorm  = .FALSE.      ! flag for computing norm (.TRUE./.FALSE.)
    logical, parameter :: ibase  = .TRUE.       ! flag to add base state to output file (.TRUE./.FALSE.)

    logical, parameter :: iterr = .FALSE.       ! flag for terrain
    real,    parameter :: hamp  = 0.6           ! height of terrain (0.6)
    real,    parameter :: asx   = 0.6           ! gaussian terrian major axis (1.0)
    real,    parameter :: asy   = 0.6           ! gaussian terrian minor axis (1.0)
    real,    parameter :: asig  = 1.0           ! eccentricity of gaussian terrain (1.0)

    integer, parameter :: kmax = 128/2          ! number of x waves
    integer, parameter :: lmax = 64/2           ! number of y waves

    logical, parameter :: hw    = .TRUE.        ! Hoskins-West jet on/off (.TRUE./.FALSE.)
    real,    parameter :: hwp   = 5.539118      ! Hoskins-West jet width parameter
    real,    parameter :: amu   = 1.0           ! Hoskins-West jet concentration parameter (0->1)
    real,    parameter :: shear = 1.0           ! shear parameter (1 for HW jet)
    real,    parameter :: trl   = 15.0          ! jet relaxation parameter [e-folding time] (20.0, 40.0, 1000.0)

    real,    parameter :: Ross  = 0.0           ! Rossby number (0.0, 0.1)
    real,    parameter :: gamma = 0.0           ! Ekman parameter (0.0, 0.075, 0.075*1.5)

    integer, parameter :: n   = 8               ! diffusion parameter
    real,    parameter :: tau = 20.0*dt         ! diffusion time scale

    real,    parameter :: XL = 20.0             ! x domain length (2*pi, 20.0, 40.0)
    real,    parameter :: YL = 2*hwp            ! y domain length (2*pi, 2*5.539118)
    real,    parameter :: H  = 1.0              ! z domain length (0.01, 0.1, 1.0, 10.0)

    real,    parameter :: ZH       = H          ! z domain length ( needed for pinv )
    integer, parameter :: pmax     = 11         ! number of vertical levels
    integer, parameter :: order    = 2          ! 0:leading order only; 1-first order only; 2-full version
    logical, parameter :: tanhgrid = .FALSE.    ! tanh grid in vertical (.TRUE./.FALSE.)

    integer, parameter :: verbose = 2           ! 0:no mesgs; 1:imp only; 2:all

    !================================
    ! do not modify below this point:
    !================================

    integer, parameter :: kmid=kmax/2,     lmid=lmax/2,     &
                          mmax=3.125*kmax, nmax=3.125*lmax, &
                          k2=mmax-kmax,    l2=nmax-lmax,    &
                          kmaxp1=kmax+1,   lmaxp1=lmax+1
    real,    parameter :: facx=2.0*pi/XL,  facy=2.0*pi/YL
    real,    parameter :: ryl=2.0*pi/hwp

    type model_static
        ! diffusion
        real                              :: dco
        ! derivative operators
        complex, dimension(2*kmax,2*lmax) :: dx,dy,dz,dzo,iz,izo,Id
        ! basic state
        complex, dimension(2*kmax,2*lmax) :: thbB,thbT
        real,    dimension(mmax,nmax)     :: thbyB,thbyT
        real,    dimension(mmax,nmax)     :: ulinB,ulinT
        real                              :: lam
        ! terrain
        real,    dimension(mmax,nmax)     :: hx,hy,hu,hv
        ! advection flags
        logical                           :: bot,top
    end type model_static

END MODULE spectral_mod
!============================================================


c     program DRSHTCC
c>> 1994-10-19 DRSHTCC  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSHTCC  Lawson  Initial Code.
c     Demo driver for SHTCC, Householder transformations.
c--S replaces "?": DR?HTCC, ?HTCC, ?MATP
      integer IDIM, JDIM, J, M, N
      parameter(IDIM = 3, JDIM = 5, M = 3, N = 2)
      real             D(IDIM,JDIM), UPARAM, ZERO
      parameter(ZERO = 0.0E0)
      data (D(1,J),J=1,5) /  0.870E0,  0.796E0,    1.0E0, 0.0E0, 0.0E0 /
      data (D(2,J),J=1,5) /  0.571E0, -0.804E0,    0.0E0, 1.0E0, 0.0E0 /
      data (D(3,J),J=1,5) / -0.960E0,  0.346E0,    0.0E0, 0.0E0, 1.0E0 /
c     ------------------------------------------------------------------
      print*,'DRSHTCC..  Demonstrate computation of a QR decomposition.'
      print*,'Given matrix A, compute orthogonal Q and triangular R'
      print*,'such that A = Q * R.'
      call SMATP(D,IDIM,M,N,'0 A =')
      do 20002 J=1,N
         call SHTCC(1,J,J+1,M,D(1,J),UPARAM,D(1,J+1),IDIM,M+N-J)
20002 continue
      call SMATP(D(1,N+1),IDIM,M,M,'0 Q [Transposed] =')
      D(2,1) = ZERO
      D(3,1) = ZERO
      D(3,2) = ZERO
      call SMATP(D,IDIM,M,N,'0 R =')
      stop
      end


      SUBROUTINE FIT(X,Y,NDATA,SIG,MWT,A,B,SIGA,SIGB,CHI2,Q)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA)
      SX=0.
      SY=0.
      ST2=0.
      B=0.
      IF(MWT.NE.0) THEN
        SS=0.
        DO 11 I=1,NDATA
          WT=1./(SIG(I)**2)
          SS=SS+WT
          SX=SX+X(I)*WT
          SY=SY+Y(I)*WT
11      CONTINUE
      ELSE
        DO 12 I=1,NDATA
          SX=SX+X(I)
          SY=SY+Y(I)
12      CONTINUE
        SS=FLOAT(NDATA)
      ENDIF
      SXOSS=SX/SS
      IF(MWT.NE.0) THEN
        DO 13 I=1,NDATA
          T=(X(I)-SXOSS)/SIG(I)
          ST2=ST2+T*T
          B=B+T*Y(I)/SIG(I)
13      CONTINUE
      ELSE
        DO 14 I=1,NDATA
          T=X(I)-SXOSS
          ST2=ST2+T*T
          B=B+T*Y(I)
14      CONTINUE
      ENDIF
      B=B/ST2
      A=(SY-SX*B)/SS
      SIGA=SQRT((1.+SX*SX/(SS*ST2))/SS)
      SIGB=SQRT(1./ST2)
      CHI2=0.
      IF(MWT.EQ.0) THEN
        DO 15 I=1,NDATA
          CHI2=CHI2+(Y(I)-A-B*X(I))**2
15      CONTINUE
        Q=1.
        SIGDAT=SQRT(CHI2/(NDATA-2))
        SIGA=SIGA*SIGDAT
        SIGB=SIGB*SIGDAT
      ELSE
        DO 16 I=1,NDATA
          CHI2=CHI2+((Y(I)-A-B*X(I))/SIG(I))**2
16      CONTINUE
        Q=GAMMQ(0.5*(NDATA-2),0.5*CHI2)
      ENDIF
      RETURN
      END


      SUBROUTINE ratint(xa,ya,n,x,y,dy)
      INTEGER n,NMAX
      REAL dy,x,y,xa(n),ya(n),TINY
      PARAMETER (NMAX=10,TINY=1.e-25)
      INTEGER i,m,ns
      REAL dd,h,hh,t,w,c(NMAX),d(NMAX)
      ns=1
      hh=abs(x-xa(1))
      do 11 i=1,n
        h=abs(x-xa(i))
        if (h.eq.0.)then
          y=ya(i)
          dy=0.0
          return
        else if (h.lt.hh) then
          ns=i
          hh=h
        endif
        c(i)=ya(i)
        d(i)=ya(i)+TINY
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          w=c(i+1)-d(i)
          h=xa(i+m)-x
          t=(xa(i)-x)*d(i)/h
          dd=t-c(i+1)
          if(dd.eq.0.)pause 'failure in ratint'
          dd=w/dd
          d(i)=c(i+1)*dd
          c(i)=t*dd
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ratint.for


C     NUMERICAL METHODS: FORTRAN Programs, (c) John H. Mathews 1994
C     To accompany the text:
C     NUMERICAL METHODS for Mathematics, Science and Engineering, 2nd Ed, 1992
C     Prentice Hall, Englewood Cliffs, New Jersey, 07632, U.S.A.
C     This free software is complements of the author.
C
C     Algorithm 7.1 (Composite Trapezoidal Rule).
C     Section 7.2, Composite Trapezoidal and Simpson's Rule, Page 365
C
      SUBROUTINE TRAPRU(F,A,B,M,Trule)
      INTEGER K,M
      DOUBLE PRECISION A,B,H,Sum,Trule,X
      EXTERNAL F
      H=(B-A)/M
      Sum=0
      DO K=1,M-1
        X=A+H*K
        Sum=Sum+F(X)
      ENDDO
      Sum=H*(F(A)+F(B)+2*Sum)/2
      Trule=Sum
      RETURN
      END

      SUBROUTINE XTRAPRU(F,A,B,M,Trule)
C     This subroutine uses labeled DO loop(s).
      INTEGER K,M
      DOUBLE PRECISION A,B,H,Sum,Trule,X
      EXTERNAL F
      H=(B-A)/M
      Sum=0
      DO 10 K=1,M-1
        X=A+H*K
        Sum=Sum+F(X)
10    CONTINUE
      Sum=H*(F(A)+F(B)+2*Sum)/2
      Trule=Sum
      RETURN
      END


C     This program is written for testing module TYPING
C
C
      PROGRAM TYPAGE_INTRINSIC
      LOGICAL L
      INTEGER I
      REAL*4 R
      REAL*8 D
      COMPLEX*8 C
      COMPLEX*16 E
      CHARACTER CH

C     Conversion intrinsics
C     =====================
      I = INT(R)
      I = INT(D)
      I = INT(C)
      I = INT(CH)               ! ERROR
      I = INT(L)                ! ERROR

      R = REAL(I)
      R = REAL(D)
      R = REAL(C)
      R = REAL(CH)              ! ERROR
      R = REAL(L)               ! ERROR

      D = DBLE(I)
      D = DBLE(R)
      D = DBLE(C)
      D = DBLE(CH)              ! ERROR
      D = DBLE(L)               ! ERROR

      C = CMPLX(I)
      C = CMPLX(R)
      C = CMPLX(D)
      C = CMPLX(CH)             ! ERROR
      C = CMPLX(L)              ! ERROR

C     Argument & Result: REAL or DOUBLE
C     ========================
      I = TAN(I)                ! ERROR
      R = TAN(R)
      D = TAN(D)
      I = TAN(C)                ! ERROR
      I = TAN(L)                ! ERROR

C     Argument & Result: REAL, DOUBLE or COMPLEX
C     =================================
      I = EXP(I)                ! ERROR
      R = EXP(R)
      D = EXP(D)
      C = EXP(C)
      I = EXP(L)                ! ERROR

      I = LOG(I)                ! ERROR
      R = LOG(R)
      D = LOG(D)
      C = LOG(C)
      I = LOG(L)                ! ERROR

C     Argument & Result: INT, REAL or DOUBLE
C     =============================
      I = MIN(I, 15, I)
      R = MIN(I, 15, R)
      D = MIN(I, 15, D)
      C = MIN(I, 15, C)         ! ERROR
      I = MIN(I, 15, L)         ! ERROR

      I = MOD(I, I)
      R = MOD(R, R)
      D = MOD(D, D)
      I = MOD(R, D)
      C = MOD(C, C)             ! ERROR

C     Intrinsic ABS: IRDC -> IRDR
C     ===========================
      I = ABS(I)
      R = ABS(R)
      D = ABS(D)
      R = ABS(C)
      C = ABS(C)
      I = ABS(L)                ! ERROR

C     Type_argument --> Type_result
C     ===================================
C     INT  ->  INT
      I = IABS(I)
      I = IABS(R)               ! ERROR
      I = IABS(D)               ! ERROR
      I = IABS(C)               ! ERROR

C     REAL -> REAL
      R = ALOG(I)               ! ERROR
      R = ALOG(R)
      R = ALOG(D)               ! ERROR
      R = ALOG(C)               ! ERROR

C     DOUBLE -> DOUBLE
      D = DLOG(I)               ! ERROR
      D = DLOG(R)               ! ERROR
      D = DLOG(D)
      D = DLOG(C)               ! ERROR

C     COMPLEX -> COMPLEX
      C = CLOG(I)               ! ERROR
      C = CLOG(R)               ! ERROR
      C = CLOG(D)               ! ERROR
      C = CLOG(C)

C     CHAR -> INT
      I = ICHAR(CH)
      D = ICHAR(R)              ! ERROR

      I = LEN(CH)
      I = LEN(R)                ! ERROR

      I = INDEX(CH)
      I = INDEX(R)              ! ERROR

C     INT      ->   CHAR
      CH = CHAR(I)
      CH = CHAR(D)              ! ERROR

C     REAL     ->   INT
      I = MIN1(I, I)            ! ERROR
      I = MIN1(R, R)
      I = MIN1(I, R)            ! ERROR
      I = MIN1(I, R, D)         ! ERROR
      I = MIN1(I, R, D, C)      ! ERROR

C     COMPLEX  ->   REAL
      R = AIMAG(I)              ! ERROR
      R = AIMAG(R)              ! ERROR
      R = AIMAG(D)              ! ERROR
      R = AIMAG(C)

C     REAL     ->   DOUBLE
      D = DPROD(I)              ! ERROR
      D = DPROD(R)
      D = DPROD(D)              ! ERROR
      D = DPROD(C)              ! ERROR

C     INT      ->   REAL
      R = AMIN0(I, I)
      R = AMIN0(I, R)           ! ERROR
      R = AMIN0(R, D)           ! ERROR
      R = AMIN0(D, C)           ! ERROR

C     CHAR     ->   LOGICAL
      L = LGE(I, CH)            ! ERROR
      L = LGE(R, CH)            ! ERROR
      L = LGE(CH, CH)

      END


      SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factor of a banded symmetric positive
C     definite (s.p.d.) block Toeplitz matrix, defined by either its
C     first block row, or its first block column, depending on the
C     routine parameter TYPET.
C
C     By subsequent calls of this routine the Cholesky factor can be
C     computed block column by block column.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  T contains the first block row of an s.p.d. block
C                     Toeplitz matrix; the Cholesky factor is upper
C                     triangular;
C             = 'C':  T contains the first block column of an s.p.d.
C                     block Toeplitz matrix; the Cholesky factor is
C                     lower triangular. This choice results in a column
C                     oriented algorithm which is usually faster.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     TRIU    CHARACTER*1
C             Specifies the structure of the last block in T, as
C             follows:
C             = 'N':  the last block has no special structure;
C             = 'T':  the last block is lower / upper triangular.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 1.
C             If TRIU = 'N',   N >= 1;
C             if TRIU = 'T',   N >= 2.
C
C     NL      (input)  INTEGER
C             The lower block bandwidth, i.e., NL + 1 is the number of
C             nonzero blocks in the first block column of the block
C             Toeplitz matrix.
C             If TRIU = 'N',   0 <= NL < N;
C             if TRIU = 'T',   1 <= NL < N.
C
C     P       (input)  INTEGER
C             The number of previously computed block rows / columns of
C             the Cholesky factor.  0 <= P <= N.
C
C     S       (input)  INTEGER
C             The number of block rows / columns of the Cholesky factor
C             to compute.  0 <= S <= N - P.
C
C     T       (input/output)  DOUBLE PRECISION array, dimension
C             (LDT,(NL+1)*K) / (LDT,K)
C             On entry, if P = 0, the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array must contain the first
C             block row / column of an s.p.d. block Toeplitz matrix.
C             On entry, if P > 0, the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array must contain the P-th
C             block row / column of the Cholesky factor.
C             On exit, if INFO = 0, then the leading K-by-(NL+1)*K /
C             (NL+1)*K-by-K part of this array contains the (P+S)-th
C             block row / column of the Cholesky factor.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K) / MAX(1,(NL+1)*K).
C
C     RB      (input/output)  DOUBLE PRECISION array, dimension
C             (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K)
C             On entry, if TYPET = 'R'  and  TRIU = 'N'  and  P > 0,
C             the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array
C             must contain the (P*K+1)-st to ((P+NL)*K)-th columns
C             of the upper Cholesky factor in banded format from a
C             previous call of this routine.
C             On entry, if TYPET = 'R'  and  TRIU = 'T'  and  P > 0,
C             the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array
C             must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns
C             of the upper Cholesky factor in banded format from a
C             previous call of this routine.
C             On exit, if TYPET = 'R'  and  TRIU = 'N', the leading
C             (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
C             upper Cholesky factor in banded format.
C             On exit, if TYPET = 'R'  and  TRIU = 'T', the leading
C             (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the
C             upper Cholesky factor in banded format.
C             On exit, if TYPET = 'C'  and  TRIU = 'N', the leading
C             (NL+1)*K-by-MIN(S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
C             Cholesky factor in banded format.
C             On exit, if TYPET = 'C'  and  TRIU = 'T', the leading
C             (NL*K+1)-by-MIN(S,N-P)*K part of this array contains
C             the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower
C             Cholesky factor in banded format.
C             For further details regarding the band storage scheme see
C             the documentation of the LAPACK routine DPBTF2.
C
C     LDRB    INTEGER
C             The leading dimension of the array RB.
C             If TRIU = 'N',   LDRB >= MAX( (NL+1)*K,1 );
C             if TRIU = 'T',   LDRB >= NL*K+1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -13,  DWORK(1)  returns the minimum
C             value of LDWORK.
C             The first 1 + ( NL + 1 )*K*K elements of DWORK should be
C             preserved during successive calls of the routine.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1 + ( NL + 1 )*K*K + NL*K.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is not (numerically) positive
C                   definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                                3
C     The algorithm requires O( K *N*NL ) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001,
C     Mar. 2004, Apr. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRIU, TYPET
      INTEGER           INFO, K, LDRB, LDT, LDWORK, N, NL, P, S
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(LDWORK), RB(LDRB,*), T(LDT,*)
C     .. Local Scalars ..
      CHARACTER         STRUCT
      LOGICAL           ISROW, LQUERY, LTRI
      INTEGER           HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB,
     $                  NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN,
     $                  WRKOPT
C     .. Local Arrays ..
      INTEGER           IPVT(1)
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGELQF, DGEQRF, DLACPY, DLASET, DPOTRF,
     $                  DTRSM, MB02CU, MB02CV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO = 0
      LTRI = LSAME( TRIU, 'T' )
      LENR = ( NL + 1 )*K
      IF ( LTRI ) THEN
         SIZR = NL*K + 1
      ELSE
         SIZR = LENR
      END IF
      ISROW  = LSAME( TYPET, 'R' )
      WRKMIN = 1 + ( LENR + NL )*K
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( (      LTRI .AND. N.LT.2 ) .OR.
     $          ( .NOT.LTRI .AND. N.LT.1 ) ) THEN
         INFO = -4
      ELSE IF ( NL.GE.N .OR. (      LTRI .AND. NL.LT.1 ) .OR.
     $                       ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN
         INFO = -5
      ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN
         INFO = -6
      ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN
         INFO = -7
      ELSE IF ( (      ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR.
     $          ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) )
     $      THEN
         INFO = -9
      ELSE IF ( (      LTRI .AND. LDRB.LT.SIZR ) .OR.
     $          ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) )
     $      THEN
         INFO = -11
      ELSE
         LQUERY = LDWORK.EQ.-1
         PDW = LENR*K + 1
         KK  = PDW + 4*K
         IF ( ISROW ) THEN
            CALL DGEQRF( K, LENR, T, LDT, DWORK, DWORK, -1, INFO )
         ELSE
            CALL DGELQF( LENR, K, T, LDT, DWORK, DWORK, -1, INFO )
         END IF
         WRKOPT = KK + INT( DWORK(1) )
         IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -13
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02GD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( S*K.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Compute the generator if P = 0.
C
      IF ( P.EQ.0 ) THEN
         IF ( ISROW ) THEN
            CALL DPOTRF( 'Upper', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
            IF ( NL.GT.0 )
     $         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K,
     $                     NL*K, ONE, T, LDT, T(1,K+1), LDT )
C
C           Copy the first block row to RB.
C
            IF ( LTRI ) THEN
C
               DO 10  I = 1, LENR - K
                  CALL DCOPY( MIN( I, K ), T(1,I), 1,
     $                        RB( MAX( SIZR-I+1, 1 ),I ), 1 )
   10          CONTINUE
C
               DO 20  I = K, 1, -1
                  CALL DCOPY( I, T(K-I+1,LENR-I+1), 1,
     $                        RB( 1,LENR-I+1 ), 1 )
   20          CONTINUE
C
            ELSE
C
               DO 30  I = 1, LENR
                  CALL DCOPY( MIN( I, K ), T(1,I), 1,
     $                        RB( MAX( SIZR-I+1, 1 ),I ), 1 )
   30          CONTINUE
C
            END IF
C
C           Quick return if N = 1.
C
            IF ( N.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K )
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K )
            POSR = K + 1
         ELSE
            CALL DPOTRF( 'Lower', K, T, LDT, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
            IF ( NL.GT.0 )
     $         CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit',
     $                     NL*K, K, ONE, T, LDT, T(K+1,1), LDT )
C
C           Copy the first block column to RB.
C
            POSR = 1
            IF ( LTRI ) THEN
C
               DO 40  I = 1, K
                  CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 )
                  POSR = POSR + 1
   40          CONTINUE
C
            ELSE
C
               DO 50  I = 1, K
                  CALL DCOPY(  LENR-I+1, T(I,I), 1, RB(1,POSR), 1 )
                  IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN
                     CALL DLASET( 'All', I-1, 1, ZERO, ZERO,
     $                            RB(LENR-I+2,POSR), LDRB )
                  END IF
                  POSR = POSR + 1
   50          CONTINUE
C
            END IF
C
C           Quick return if N = 1.
C
            IF ( N.EQ.1 ) THEN
               DWORK(1) = ONE
               RETURN
            END IF
C
            CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR )
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR )
         END IF
         PRE  = 1
         STPS = S - 1
      ELSE
         PRE  = P
         STPS = S
         POSR = 1
      END IF
C
      HEAD = MOD( ( PRE - 1 )*K, LENR )
C
C     Determine block size for the involved block Householder
C     transformations.
C
      NB = MIN( INT( ( LDWORK - KK )/LENR ), K )
      IF ( ISROW ) THEN
         NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) )
      ELSE
         NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) )
      END IF
      IF ( NB.LT.NBMIN )  NB = 0
C
C     Generator reduction process.
C
      IF ( ISROW ) THEN
C
         DO 90  I = PRE, PRE + STPS - 1
            CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1,
     $                   DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1),
     $                   ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The positive definiteness is (numerically)
C                             not satisfied.
C
               INFO = 1
               RETURN
            END IF
C
            LEN  = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 )
            LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 )
            IF ( LEN.EQ.( LENR-K ) ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1,
     $                   DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT,
     $                   DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( ( N - I )*K.GE.LENR ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1,
     $                   DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT,
     $                   DUM, 1, DWORK(2), K, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K )
C
C           Copy current block row to RB.
C
            IF ( LTRI ) THEN
C
               DO 60  J = 1, MIN( LEN + LEN2 + K, LENR - K )
                  CALL DCOPY(  MIN( J, K ), T(1,J), 1,
     $                         RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 )
   60          CONTINUE
C
               IF ( LEN+LEN2+K.GE.LENR ) THEN
C
                  DO 70  JJ = K, 1, -1
                     CALL DCOPY(  JJ, T(K-JJ+1,LENR-JJ+1), 1,
     $                            RB(1,POSR+LENR-JJ), 1 )
   70             CONTINUE
C
               END IF
               POSR = POSR + K
C
            ELSE
C
               DO 80  J = 1, LEN + LEN2 + K
                  CALL DCOPY(  MIN( J, K ), T(1,J), 1,
     $                         RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 )
                  IF ( J.GT.LENR-K ) THEN
                     CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO,
     $                            RB(1,POSR+J-1), 1 )
                  END IF
   80          CONTINUE
C
               POSR = POSR + K
            END IF
            HEAD = MOD( HEAD + K, LENR )
   90    CONTINUE
C
      ELSE
C
         DO 120  I = PRE, PRE + STPS - 1
C
            CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1,
     $                   DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1),
     $                   ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The positive definiteness is (numerically)
C                             not satisfied.
C
               INFO = 1
               RETURN
            END IF
C
            LEN  = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 )
            LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 )
            IF ( LEN.EQ.( LENR-K ) ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM,
     $                   1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT,
     $                   DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            IF ( ( N - I )*K.GE.LENR ) THEN
               STRUCT = TRIU
            ELSE
               STRUCT = 'N'
            END IF
            CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM,
     $                   1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1),
     $                   LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1),
     $                   DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR )
C
            CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR )
C
C           Copy current block column to RB.
C
            IF ( LTRI ) THEN
C
               DO 100  J = 1, K
                  CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1,
     $                        RB(1,POSR), 1 )
                  POSR = POSR + 1
  100          CONTINUE
C
            ELSE
C
               DO 110  J = 1, K
                  CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1,
     $                        RB(1,POSR), 1 )
                  IF ( LENR.LT.(N-I)*K ) THEN
                     CALL DLASET( 'All', J-1, 1, ZERO, ZERO,
     $                             RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1,
     $                                POSR), LDRB )
                  END IF
                  POSR = POSR + 1
  110          CONTINUE
C
            END IF
            HEAD = MOD( HEAD + K, LENR )
  120    CONTINUE
C
      END IF
      DWORK(1) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of MB02GD ***
      END


subroutine gen_kp(m1,m2,m3,n1,n2,n3,bz,GS,G,l)

implicit none

integer, intent(in):: n1,n2,n3
Integer, intent(in):: m1,m2,m3,bz
double precision, intent(in):: GS(3,3)
integer, intent(in):: l
double precision, intent(in):: G(l,3)

double precision  :: kp(3)
double precision :: kr, kt

integer :: i,j,k,count,s
logical :: keep

open(1, file="BZ_ZONE.dat", status="new", action="write")

!$omp parallel private(kp,kr,count,kt,keep)
!$omp do
do i=0,n1-1
	do j=0,n2-1
		do k=0,n3-1
			count=0
			keep = .true.
			kp(1)=m1*(-1.0+2.0*i/(n1-1))*Gs(1,1)+m2*(-1.0+2.0*j/(n2-1))*Gs(2,1)+m3*(-1.0+2.0*k/(n3-1))*Gs(3,1)
			kp(2)=m1*(-1.0+2.0*i/(n1-1))*Gs(1,2)+m2*(-1.0+2.0*j/(n2-1))*Gs(2,2)+m3*(-1.0+2.0*k/(n3-1))*Gs(3,2)
			kp(3)=m1*(-1.0+2.0*i/(n1-1))*Gs(1,3)+m2*(-1.0+2.0*j/(n2-1))*Gs(2,3)+m3*(-1.0+2.0*k/(n3-1))*Gs(3,3)
			kt=(kp(1)**2+kp(2)**2+kp(3)**2)
			do s=1,l
				kr=(G(s,1)-kp(1))**2+(G(s,2)-kp(2))**2+(G(s,3)-kp(3))**2
				if(kt.gt.kr) then
					count=count+1
				end if
				if(count .ge. bz) then
					keep = .false.
					exit
				endif
			enddo
			if (((count+1) .eq. bz) .AND. keep) write(1,666) kp(1), kp(2),kp(3), SQRT(kt), count+1
		enddo
	enddo
enddo
!$omp end do
!$omp end parallel
 close(1)
666 format(f20.3,1x,f20.3,1x,f20.3,1x,f20.3,1x,i3)

end subroutine gen_kp


!  Efficient Fortran methods for computing measures.
!
!! @author Michael P. Howard

!> @brief Calculates the Minkowski functionals for a 3D array.
!!
!! The Minkowski functionals (volume, surface area, integral mean
!! curvature, Euler characteristic) are computed for a domain
!! represented by a 3D *lattice*. The lattice is digitized into
!! 1s and 0s, and the active domain is all the 1s. The lattice
!! is 0-indexed, and the voxels are assumed to be cubes of size *a*.
!! The units of the returned functionals are implicitly in *a*.
!!
!! Additional details can be found in the reference from which
!! this routine was taken::
!!   K. Michielsen and H. De Raedt, Integral-geometry morphological
!!   analysis, Physics Report 347, 461-538 (2001).
!! @see minkowski_add_voxel
!!
!! @param[in]   lattice     3D array of integers.
!! @param[in]   Lx          Size of lattice in x.
!! @param[in]   Ly          Size of lattice in y.
!! @param[in]   Lz          Size of lattice in z.
!! @param[out]  volume      Volume of active lattice.
!! @param[out]  surface     Surface area of active lattice.
!! @param[out]  curvature   Mean curvature of active lattice.
!! @param[out]  euler       Euler characteristic of active lattice.
!!
subroutine minkowski(lattice,Lx,Ly,Lz,volume,surface,curvature,euler)
implicit none
integer, intent(in), dimension(0:Lx-1,0:Ly-1,0:Lz-1) :: lattice
integer, intent(in) :: Lx, Ly, Lz
integer, intent(out) :: volume, surface, curvature, euler

integer, dimension(0:Lx-1,0:Ly-1,0:Lz-1) :: tmp
integer v,s,c,e
integer jx,jy,jz

! fill all tmp pixels with 0
tmp = 0

! loop over pixels and accumulate functionals
volume = 0
surface = 0
curvature = 0
euler = 0
do jz = 0,Lz-1
do jy = 0,Ly-1
do jx = 0,Lx-1
    if (lattice(jx,jy,jz) > 0) then ! active pixel
        call minkowski_add_voxel(tmp,Lx,Ly,Lz,jx,jy,jz,v,s,c,e)
        tmp(jx,jy,jz) = 1 ! add pixel to image
        volume = volume + v
        surface = surface + s
        curvature = curvature + c
        euler = euler + e
    end if
end do ! jx
end do ! jy
end do ! jz
end subroutine

!> @brief Calculates the change in Minkowski functionals on addition of a pixel.
!!
!! The changes in the Minkowski functionals (volume, surface area,
!! integral mean curvature, Euler characteristic) are computed from
!! adding a voxel at (*jx*,*jy*,*jz*) to the 3D *lattice*. The lattice
!! is 0-indexed, and the voxels are assumed to be cubes of size *a*.
!! The units of the returned functionals are implicitly in *a*.
!!
!! Reference equations can be found in Appendix B of::
!!   K. Michielsen and H. De Raedt, Integral-geometry morphological
!!   analysis, Physics Report 347, 461-538 (2001).
!! @see minkowski
!!
!! @param[in]   lattice     3D array of integers.
!! @param[in]   Lx          Size of lattice in x.
!! @param[in]   Ly          Size of lattice in y.
!! @param[in]   Lz          Size of lattice in z.
!! @param[in]   jx          Added voxel x-coordinate.
!! @param[in]   jy          Added voxel y-coordinate.
!! @param[in]   jz          Added voxel z-coordinate.
!! @param[out]  volume      Change in volume.
!! @param[out]  surface     Change in surface area.
!! @param[out]  curvature   Change in mean curvature.
!! @param[out]  euler       Change in Euler characteristic.
!!
subroutine minkowski_add_voxel(lattice,Lx,Ly,Lz,jx,jy,jz,volume,surface,curvature,euler)
implicit none
integer, intent(in), dimension(0:Lx-1,0:Ly-1,0:Lz-1) :: lattice
integer, intent(in) :: Lx, Ly, Lz, jx, jy, jz
integer, intent(out) :: volume, surface, curvature, euler

integer, parameter :: volume_body = 1   ! (a*a*a, where a is lattice displacement)
integer, parameter :: surface_body = -6 ! (-6*a*a, open body)
integer, parameter :: surface_face = 2  ! (2*a*a, open face)
integer, parameter :: curv_body = 3     ! (3*a, open body)
integer, parameter :: curv_face = -2    ! (-2*a, open face)
integer, parameter :: curv_edge = 1     ! (a, open line)
integer, parameter :: euler_body = -1   ! (open body)
integer, parameter :: euler_face = 1    ! (open face)
integer, parameter :: euler_edge = -1   ! (open line)
integer, parameter :: euler_vertex = 1  ! (vertices)

integer nfaces, nedges, nvert
integer i0,j0,k0,jxi,jyi,jzi,jyj,jzj,jzk
integer kc1,kc2,kc3,kc7,kc1kc4kc5

! accumulate faces, edges, vertices from adding pixel
nfaces = 0
nedges = 0
nvert = 0
do i0 = -1,1,2
    ! wrap offsets to account for periodic boundaries
    jxi = modulo(jx+i0,Lx)
    jyi = modulo(jy+i0,Ly)
    jzi = modulo(jz+i0,Lz)
    kc1 = 1-lattice(jxi,jy,jz)
    kc2 = 1-lattice(jx,jyi,jz)
    kc3 = 1-lattice(jx,jy,jzi)
    nfaces = nfaces + kc1 + kc2 + kc3 ! (B.5)
    do j0 = -1,1,2
        jyj = modulo(jy+j0,Ly)
        jzj = modulo(jz+j0,Lz)
        kc7 = 1-lattice(jx,jy,jzj)
        kc1kc4kc5 = kc1*(1-lattice(jxi,jyj,jz))*(1-lattice(jx,jyj,jz))
        nedges = nedges + kc1kc4kc5 + kc2*(1-lattice(jx,jyi,jzj))*kc7 + kc1*(1-lattice(jxi,jy,jzj))*kc7 ! (B.6)
        if (kc1kc4kc5.ne.0) then ! whole term (B.7) evaluates to 0 otherwise
            do k0 = -1,1,2
                jzk = modulo(jz+k0,Lz)
                nvert = nvert + (1-lattice(jxi,jy,jzk))*(1-lattice(jxi,jyj,jzk))*(1-lattice(jx,jyj,jzk))*(1-lattice(jx,jy,jzk)) ! (B.7, without kc1kc4kc5)
            end do !k0
        end if
    end do ! j0
end do ! i0

volume = volume_body
surface = surface_body + surface_face*nfaces
curvature = curv_body + curv_face*nfaces + curv_edge*nedges
euler = euler_body + euler_face*nfaces + euler_edge*nedges + euler_vertex*nvert
end subroutine


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c     This version of gaqd implements the method presented in:
c     P. N. swarztrauber, Computing the points and weights for
c     Gauss-Legendre quadrature, SIAM J. Sci. Comput.,
c     24(2002) pp. 945-954.
c
c     The w and lwork arrays are dummy and included only to
c     permit a simple pluggable exchange with the
c     old gaqd in previous versions of SPHEREPACK
c
c
c
      subroutine gaqd(nlat,theta,wts,w,lwork,ierror)
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c     gauss points and weights are computed using the fourier-newton
c     described in "on computing the points and weights for
c     gauss-legendre quadrature", paul n. swarztrauber, siam journal
c     on scientific computing that has been accepted for publication.
c     This routine is faster and more accurate than older program
c     with the same name.
c
c     subroutine gaqd computes the nlat gaussian colatitudes and weights
c     in double precision. the colatitudes are in radians and lie in the
c     in the interval (0,pi).
c
c     input parameters
c
c     nlat    the number of gaussian colatitudes in the interval (0,pi)
c             (between the two poles).  nlat must be greater than zero.
c
c     w       unused double precision variable that permits a simple
c             exchange with the old routine with the same name
c             in spherepack.
c
c     lwork   unused variable that permits a simple exchange with the
c             old routine with the same name in spherepack.
c
c     output parameters
c
c     theta   a double precision array with length nlat
c             containing the gaussian colatitudes in
c             increasing radians on the interval (0,pi).
c
c     wts     a double precision array with lenght nlat
c             containing the gaussian weights.
c
c     ierror = 0 no errors
c            = 1 if nlat.le.0
c
c  *****************************************************************
c
      double precision theta(nlat),wts(nlat),w,
     1 x,pi,pis2,dtheta,dthalf,cmax,zprev,zlast,zero,
     2 zhold,pb,dpb,dcor,sum,cz
c
c     check work space length
c
      ierror = 1
      if (nlat.le.0) return
      ierror = 0
c
c     compute weights and points analytically when nlat=1,2
c
      if (nlat.eq.1) then
      theta(1) = dacos(0.0d0)
      wts(1) = 2.0d0
      return
      end if
      if (nlat.eq.2) then
      x = dsqrt(1.0d0/3.0d0)
      theta(1) = dacos(x)
      theta(2) = dacos(-x)
      wts(1) = 1.0d0
      wts(2) = 1.0d0
      return
      end if
      eps = sqrt(dzeps(1.0d0))
      eps = eps*sqrt(eps)
      pis2 = 2.0d0*datan(1.0d0)
      pi = pis2+pis2
      mnlat = mod(nlat,2)
      ns2 = nlat/2
      nhalf = (nlat+1)/2
      idx = ns2+2
c
      call cpdp (nlat,cz,theta(ns2+1),wts(ns2+1))
c
      dtheta = pis2/nhalf
      dthalf = dtheta/2.0d0
      cmax = .2d0*dtheta
c
c     estimate first point next to theta = pi/2
c
      if(mnlat.ne.0) then
      zero = pis2-dtheta
      zprev = pis2
      nix = nhalf-1
      else
      zero = pis2-dthalf
      nix = nhalf
      end if
 9    it = 0
 10   it = it+1
      zlast = zero
c
c     newton iterations
c
      call tpdp (nlat,zero,cz,theta(ns2+1),wts(ns2+1),pb,dpb)
      dcor = pb/dpb
      sgnd = 1.0
      if(dcor .ne. 0.0d0) sgnd = dcor/dabs(dcor)
      dcor = sgnd*min(dabs(dcor),cmax)
      zero = zero-dcor
      if(dabs(zero-zlast).gt.eps*dabs(zero)) go to 10
      theta(nix) = zero
      zhold = zero
c      wts(nix) = (nlat+nlat+1)/(dpb*dpb)
c
c     yakimiw's formula permits using old pb and dpb
c
      wts(nix) = (nlat+nlat+1)/(dpb+pb*dcos(zlast)/dsin(zlast))**2
      nix = nix-1
      if(nix.eq.0) go to 30
      if(nix.eq.nhalf-1)  zero = 3.0*zero-pi
      if(nix.lt.nhalf-1)  zero = zero+zero-zprev
      zprev = zhold
      go to 9
c
c     extend points and weights via symmetries
c
 30   if(mnlat.ne.0) then
      theta(nhalf) = pis2
      call tpdp (nlat,pis2,cz,theta(ns2+1),wts(ns2+1),pb,dpb)
      wts(nhalf) = (nlat+nlat+1)/(dpb*dpb)
      end if
      do i=1,ns2
      wts(nlat-i+1) = wts(i)
      theta(nlat-i+1) = pi-theta(i)
      end do
      sum = 0.0d0
      do i=1,nlat
      sum = sum+wts(i)
      end do
      do i=1,nlat
      wts(i) = 2.0d0*wts(i)/sum
      end do
      return
      end
      subroutine cpdp(n,cz,cp,dcp)
c
c     computes the fourier coefficients of the legendre
c     polynomial p_n^0 and its derivative.
c     n is the degree and n/2 or (n+1)/2
c     coefficients are returned in cp depending on whether
c     n is even or odd. The same number of coefficients
c     are returned in dcp. For n even the constant
c     coefficient is returned in cz.
c
      double precision cp(n/2+1),dcp(n/2+1),
     1 t1,t2,t3,t4,cz
      ncp = (n+1)/2
      t1 = -1.0d0
      t2 = n+1.0d0
      t3 = 0.0d0
      t4 = n+n+1.0d0
      if(mod(n,2).eq.0) then
      cp(ncp) = 1.0d0
      do j = ncp,2,-1
      t1 = t1+2.0d0
      t2 = t2-1.0d0
      t3 = t3+1.0d0
      t4 = t4-2.0d0
      cp(j-1) = (t1*t2)/(t3*t4)*cp(j)
      end do
      t1 = t1+2.0d0
      t2 = t2-1.0d0
      t3 = t3+1.0d0
      t4 = t4-2.0d0
      cz = (t1*t2)/(t3*t4)*cp(1)
      do j=1,ncp
      dcp(j) = (j+j)*cp(j)
      end do
      else
      cp(ncp) = 1.0d0
      do j = ncp-1,1,-1
      t1 = t1+2.0d0
      t2 = t2-1.0d0
      t3 = t3+1.0d0
      t4 = t4-2.0d0
      cp(j) = (t1*t2)/(t3*t4)*cp(j+1)
      end do
      do j=1,ncp
      dcp(j) = (j+j-1)*cp(j)
      end do
      end if
      return
      end
      subroutine tpdp (n,theta,cz,cp,dcp,pb,dpb)
c
c     computes pn(theta) and its derivative dpb(theta) with
c     respect to theta
c
      double precision cp(n/2+1),dcp(n/2+1),cz,
     1  pb,dpb,fn,theta,cdt,sdt,cth,sth,chh
c
      fn = n
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      if(mod(n,2) .eq.0) then
c
c     n even
c
      kdo = n/2
      pb = .5d0*cz
      dpb = 0.0d0
      if(n .gt. 0) then
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c      pb = pb+cp(k)*cos(2*k*theta)
      pb = pb+cp(k)*cth
c      dpb = dpb-(k+k)*cp(k)*sin(2*k*theta)
      dpb = dpb-dcp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      end if
      else
c
c     n odd
c
      kdo = (n+1)/2
      pb = 0.0d0
      dpb = 0.0d0
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c      pb = pb+cp(k)*cos((2*k-1)*theta)
      pb = pb+cp(k)*cth
c      dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta)
      dpb = dpb-dcp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      end if
      return
      end
      real function dzeps (x)
      double precision  x
c
c     estimate unit roundoff in quantities of size x.
c
      double precision a,b,c,eps
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing floating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in floating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger floating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     this version dated 4/6/83.
c
      a = 4.0d0/3.0d0
   10 b = a - 1.0d0
      c = b + b + b
      eps = abs(c-1.0d0)
      if (eps .eq. 0.0d0) go to 10
      dzeps = eps*dabs(x)
      return
      end


subroutine eval_volume(u, v, w, tu, tv, tw, ku, kv, kw, coef, &
     nctlu, nctlv, nctlw, ndim, n, m, l, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_volume evaluates (possibly) many points on the
  !              b-spline volume
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate, size(l, m, n)
  !     v       - Real, v coordinate, size(l, m, n)
  !     w       - Real, w coordinate, size(l, m, n)
  !     tu      - Real, Knot vector in u. Length nctlu+ku
  !     tv      - Real, Knot vector in v. Length nctlv+kv
  !     tw      - Real, Knot vector in w. Length nctlv+kw
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     kw      - Integer, order of B-spline in w
  !     coef    - Real, Array of B-spline coefficients
  !                 Size (ndim, nctlw, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     nctlw   - Integer, Number of control points in w
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated points, size (ndim, l, m, n)

  use precision
  implicit none

  ! Input
  integer            , intent(in)   :: ku, kv, kw, nctlu, nctlv, nctlw
  integer            , intent(in)   :: ndim, n, m, l
  real(kind=realType), intent(in)   :: u(l, m, n) , v(l, m, n), w(l, m, n)
  real(kind=realType), intent(in)   :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)
  real(kind=realType), intent(in)   :: coef(ndim, nctlw, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out)  :: val(ndim, l, m, n)

  ! Working
  integer                           :: idim, istartu, istartv, istartw
  integer                           :: i, j, k, ii, jj, kk
  integer                           :: ileftu, ileftv, ileftw
  real(kind=realType)               :: basisu(ku), basisv(kv), basisw(kw)

  val(:, :, :, :) = 0.0
  do ii=1, n
     do jj=1, m
        do kk=1, l
           ! U
           call findSpan(u(kk, jj, ii), ku, tu, nctlu, ileftu)
           call basis(tu, nctlu, ku, u(kk, jj, ii), ileftu, basisu)
           istartu = ileftu-ku

           ! V
           call findSpan(v(kk, jj, ii), kv, tv, nctlv, ileftv)
           call basis(tv, nctlv, kv, v(kk, jj, ii), ileftv, basisv)
           istartv = ileftv-kv

           ! W
           call findSpan(w(kk, jj, ii), kw, tw, nctlw, ileftw)
           call basis(tw, nctlw, kw, w(kk, jj, ii), ileftw, basisw)
           istartw = ileftw-kw

           do i=1, ku
              do j=1, kv
                 do k=1, kw
                    do idim=1, ndim
                       val(idim, kk, jj, ii) = val(idim, kk, jj, ii) + &
                            basisu(i)*basisv(j)*basisw(k)*&
                            coef(idim, istartw+k, istartv+j, istartu+i)
                    end do
                 end do
              end do
           end do
        end do
     end do
  end do
end subroutine eval_volume

subroutine eval_volume_deriv(u, v, w, tu, tv, tw, ku, kv, kw, coef, &
     nctlu, nctlv, nctlw, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_volume_deriv evaluates the first derivative on a
  !              volume
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate
  !     v       - Real, v coordinate
  !     w       - Real, w coordinate
  !     tu      - Real, Knot vector in u. Length nctlu+ku
  !     tv      - Real, Knot vector in v. Length nctlv+kv
  !     tw      - Real, Knot vector in w. Length nctlv+kw
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     kw      - Integer, order of B-spline in w
  !     coef    - Real, Array of B-spline coefficients
  !                 Size (ndim, nctlw, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     nctlw   - Integer, Number of control points in w
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated derivatvie, size(ndim, 3)

  use precision
  implicit none

  ! Input
  integer            , intent(in)   :: ku, kv, kw, nctlu, nctlv, nctlw, ndim
  real(kind=realType), intent(in)   :: u , v, w
  real(kind=realType), intent(in)   :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)
  real(kind=realType), intent(in)   :: coef(ndim, nctlw, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out)  :: val(ndim, 3)

  ! Working
  integer                           :: idim
  real(kind=realType)               :: b3val

  do idim=1, ndim
     val(idim, 1) = b3val(w, v, u, 0, 0, 1, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))

     val(idim, 2) = b3val(w, v, u, 0, 1, 0, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))

     val(idim, 3) = b3val(w, v, u, 1, 0, 0, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))
  end do
end subroutine eval_volume_deriv

subroutine eval_volume_deriv2(u, v, w, tu, tv, tw, ku, kv, kw, coef, &
     nctlu, nctlv, nctlw, ndim, val)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract eval_volume_deriv2 evaluates the second derivative on a
  !              volume
  !
  !     Description of Arguments
  !     Input
  !     u       - Real, u coordinate
  !     v       - Real, v coordinate
  !     w       - Real, w coordinate
  !     tu      - Real, Knot vector in u. Length nctlu+ku
  !     tv      - Real, Knot vector in v. Length nctlv+kv
  !     tw      - Real, Knot vector in w. Length nctlv+kw
  !     ku      - Integer, order of B-spline in u
  !     kv      - Integer, order of B-spline in v
  !     kw      - Integer, order of B-spline in w
  !     coef    - Real, Array of B-spline coefficients
  !                 Size (ndim, nctlw, nctlv, nctlu)
  !     nctlu   - Integer, Number of control points in u
  !     nctlv   - Integer, Number of control points in v
  !     nctlw   - Integer, Number of control points in w
  !     ndim    - Integer, Spatial Dimension
  !
  !     Ouput
  !     val     - Real, Evaluated derivatvie, size(ndim, 3, 3)

  use precision
  implicit none
  ! Input
  integer            , intent(in)  :: ku, kv, kw, nctlu, nctlv, nctlw, ndim
  real(kind=realType), intent(in)  :: u, v, w
  real(kind=realType), intent(in)  :: tu(nctlu+ku), tv(nctlv+kv), tw(nctlw+kw)
  real(kind=realType), intent(in)  :: coef(ndim, nctlw, nctlv, nctlu)

  ! Output
  real(kind=realType), intent(out) :: val(ndim, 3, 3)

  ! Working
  integer                          :: idim

  real(kind=realType)              :: b3val

  do idim=1, ndim

     ! Row 1
     if (ku>=3) then
        val(idim, 1, 1) = b3val(w, v, u, 0, 0, 2, tw, tv, tu, nctlw, nctlv, &
             nctlu, kw, kv, ku, coef(idim, :, :, :))
     else
        val(idim, 1, 1) = 0.0
     end if
     val(idim, 1, 2) = b3val(w, v, u, 0, 1, 1, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))
     val(idim, 1, 3) = b3val(w, v, u, 1, 0, 1, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))

     ! Row 2
     val(idim, 2, 1) = val(idim, 1, 2)
     if (kv>=3) then
        val(idim, 2, 2) = b3val(w, v, u, 0, 2, 0, tw, tv, tu, nctlw, nctlv, &
             nctlu, kw, kv, ku, coef(idim, :, :, :))
     else
        val(idim, 2, 2) = 0.0
     end if
     val(idim, 2, 3) = b3val(w , v , u, 1, 1, 0, tw, tv, tu, nctlw, nctlv, nctlu, &
          kw, kv, ku, coef(idim, :, :, :))

     ! Row 3
     val(idim, 3, 1) = val(idim, 1, 3)
     val(idim, 3, 2) = val(idim, 2, 3)
     if (kw>=3) then
        val(idim, 3, 3) = b3val(w, v, u, 2, 0, 0, tw, tv, tu, nctlw, nctlv, &
             nctlu, kw, kv, ku, coef(idim, :, :, :))
     else
        val(idim, 3, 3) = 0.0
     end if
  end do

end subroutine eval_volume_deriv2


      FUNCTION ran3(idum)
      INTEGER idum
      INTEGER MBIG,MSEED,MZ
C     REAL MBIG,MSEED,MZ
      REAL ran3,FAC
      PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG)
C     PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG)
      INTEGER i,iff,ii,inext,inextp,k
      INTEGER mj,mk,ma(55)
C     REAL mj,mk,ma(55)
      SAVE iff,inext,inextp,ma
      DATA iff /0/
      if(idum.lt.0.or.iff.eq.0)then
        iff=1
        mj=MSEED-iabs(idum)
        mj=mod(mj,MBIG)
        ma(55)=mj
        mk=1
        do 11 i=1,54
          ii=mod(21*i,55)
          ma(ii)=mk
          mk=mj-mk
          if(mk.lt.MZ)mk=mk+MBIG
          mj=ma(ii)
11      continue
        do 13 k=1,4
          do 12 i=1,55
            ma(i)=ma(i)-ma(1+mod(i+30,55))
            if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG
12        continue
13      continue
        inext=0
        inextp=31
        idum=1
      endif
      inext=inext+1
      if(inext.eq.56)inext=1
      inextp=inextp+1
      if(inextp.eq.56)inextp=1
      mj=ma(inext)-ma(inextp)
      if(mj.lt.MZ)mj=mj+MBIG
      ma(inext)=mj
      ran3=mj*FAC
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ran3.for