      SUBROUTINE B2INK(X,NX,Y,NY,FCN,LDF,KX,KY,TX,TY,BCOEF,WORK,IFLAG)
C***BEGIN PROLOGUE  B2INK
C***DATE WRITTEN   25 MAY 1982
C***REVISION DATE  25 MAY 1982
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  E1A
C***KEYWORDS  INTERPOLATION, TWO-DIMENSIONS, GRIDDED DATA, SPLINES,
C             PIECEWISE POLYNOMIALS
C***AUTHOR  BOISVERT, RONALD, NBS
C             SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, DC 20234
C***PURPOSE  B2INK DETERMINES A PIECEWISE POLYNOMIAL FUNCTION THAT
C            INTERPOLATES TWO-DIMENSIONAL GRIDDED DATA. USERS SPECIFY
C            THE POLYNOMIAL ORDER (DEGREE+1) OF THE INTERPOLANT AND
C            (OPTIONALLY) THE KNOT SEQUENCE.
C***DESCRIPTION
C
C   B2INK determines the parameters of a function that interpolates the
C   two-dimensional gridded data (X(i),Y(j),FCN(i,j)) for i=1,..,NX and
C   j=1,..,NY. The  interpolating  function  and  its  derivatives  may
C   subsequently be evaluated by the function B2VAL.
C
C   The interpolating  function  is  a  piecewise  polynomial  function
C   represented as a tensor product of one-dimensional  B-splines.  The
C   form of this function is
C
C                          NX   NY
C              S(x,y)  =  SUM  SUM  a   U (x) V (y)
C                         i=1  j=1   ij  i     j
C
C   where the functions U(i)  and  V(j)  are  one-dimensional  B-spline
C   basis functions. The coefficients a(i,j) are chosen so that
C
C         S(X(i),Y(j)) = FCN(i,j)   for i=1,..,NX and j=1,..,NY
C
C   Note that  for  each  fixed  value  of  y  S(x,y)  is  a  piecewise
C   polynomial function of x alone, and for each fixed value of x  S(x,
C   y) is a piecewise polynomial function of y alone. In one  dimension
C   a piecewise polynomial may  be  created  by  partitioning  a  given
C   interval into subintervals and defining a distinct polynomial piece
C   on each one. The points where adjacent subintervals meet are called
C   knots. Each of the functions U(i) and V(j)  above  is  a  piecewise
C   polynomial.
C
C   Users of B2INK choose the order (degree+1) of the polynomial pieces
C   used to define the piecewise polynomial in each  of  the  x  and  y
C   directions (KX and KY).  Users  also  may  define  their  own  knot
C   sequence in x and y separately (TX and TY).  If  IFLAG=0,  however,
C   B2INK will choose sequences of knots that  result  in  a  piecewise
C   polynomial interpolant with KX-2 continuous partial derivatives  in
C   x and KY-2 continuous partial derivatives in y. (KX knots are taken
C   near each endpoint, not-a-knot end conditions  are  used,  and  the
C   remaining knots are placed at data points  if  KX  is  even  or  at
C   midpoints between data points if KX is  odd.  The  y  direction  is
C   treated similarly.)
C
C   After a call to B2INK, all  information  necessary  to  define  the
C   interpolating function are contained in the parameters NX, NY,  KX,
C   KY, TX, TY, and BCOEF. These quantities should not be altered until
C   after the last call of the evaluation routine B2VAL.
C
C
C   I N P U T
C   ---------
C
C   X       Real 1D array (size NX)
C           Array of x abcissae. Must be strictly increasing.
C
C   NX      Integer scalar (.GE. 3)
C           Number of x abcissae.
C
C   Y       Real 1D array (size NY)
C           Array of y abcissae. Must be strictly increasing.
C
C   NY      Integer scalar (.GE. 3)
C           Number of y abcissae.
C
C   FCN     Real 2D array (size LDF by NY)
C           Array of function values to interpolate. FCN(I,J) should
C           contain the function value at the point (X(I),Y(J))
C
C   LDF     Integer scalar (.GE. NX)
C           The actual leading dimension of FCN used in the calling
C           calling program.
C
C   KX      Integer scalar (.GE. 2, .LT. NX)
C           The order of spline pieces in x.
C           (Order = polynomial degree + 1)
C
C   KY      Integer scalar (.GE. 2, .LT. NY)
C           The order of spline pieces in y.
C           (Order = polynomial degree + 1)
C
C
C   I N P U T   O R   O U T P U T
C   -----------------------------
C
C   TX      Real 1D array (size NX+KX)
C           The knots in the x direction for the spline interpolant.
C           If IFLAG=0 these are chosen by B2INK.
C           If IFLAG=1 these are specified by the user.
C                      (Must be non-decreasing.)
C
C   TY      Real 1D array (size NY+KY)
C           The knots in the y direction for the spline interpolant.
C           If IFLAG=0 these are chosen by B2INK.
C           If IFLAG=1 these are specified by the user.
C                      (Must be non-decreasing.)
C
C
C   O U T P U T
C   -----------
C
C   BCOEF   Real 2D array (size NX by NY)
C           Array of coefficients of the B-spline interpolant.
C           This may be the same array as FCN.
C
C
C   M I S C E L L A N E O U S
C   -------------------------
C
C   WORK    Real 1D array (size NX*NY + max( 2*KX*(NX+1),
C                                  2*KY*(NY+1) ))
C           Array of working storage.
C
C   IFLAG   Integer scalar.
C           On input:  0 == knot sequence chosen by B2INK
C                      1 == knot sequence chosen by user.
C           On output: 1 == successful execution
C                      2 == IFLAG out of range
C                      3 == NX out of range
C                      4 == KX out of range
C                      5 == X not strictly increasing
C                      6 == TX not non-decreasing
C                      7 == NY out of range
C                      8 == KY out of range
C                      9 == Y not strictly increasing
C                     10 == TY not non-decreasing
C
C***REFERENCES  CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES,
C                 SPRINGER-VERLAG, NEW YORK, 1978.
C               CARL DE BOOR, EFFICIENT COMPUTER MANIPULATION OF TENSOR
C                 PRODUCTS, ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C                 VOL. 5 (1979), PP. 173-182.
C***ROUTINES CALLED  BTPCF,BKNOT
C***END PROLOGUE  B2INK
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        NX, NY, LDF, KX, KY, IFLAG
      REAL
     *     X(NX), Y(NY), FCN(LDF,NY), TX(*), TY(*), BCOEF(NX,NY),
     *     WORK(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, IW, NPK
C
C  -----------------------
C  CHECK VALIDITY OF INPUT
C  -----------------------
C
C***FIRST EXECUTABLE STATEMENT
      IF ((IFLAG .LT. 0) .OR. (IFLAG .GT. 1))  GO TO 920
      IF (NX .LT. 3)  GO TO 930
      IF (NY .LT. 3)  GO TO 970
      IF ((KX .LT. 2) .OR. (KX .GE. NX))  GO TO 940
      IF ((KY .LT. 2) .OR. (KY .GE. NY))  GO TO 980
      DO 10 I=2,NX
         IF (X(I) .LE. X(I-1))  GO TO 950
   10 CONTINUE
      DO 20 I=2,NY
         IF (Y(I) .LE. Y(I-1))  GO TO 990
   20 CONTINUE
      IF (IFLAG .EQ. 0)  GO TO 50
         NPK = NX + KX
         DO 30 I=2,NPK
            IF (TX(I) .LT. TX(I-1))  GO TO 960
   30    CONTINUE
         NPK = NY + KY
         DO 40 I=2,NPK
            IF (TY(I) .LT. TY(I-1))  GO TO 1000
   40    CONTINUE
   50 CONTINUE
C
C  ------------
C  CHOOSE KNOTS
C  ------------
C
      IF (IFLAG .NE. 0)  GO TO 100
         CALL BKNOT(X,NX,KX,TX)
         CALL BKNOT(Y,NY,KY,TY)
  100 CONTINUE
C
C  -------------------------------
C  CONSTRUCT B-SPLINE COEFFICIENTS
C  -------------------------------
C
      IFLAG = 1
      IW = NX*NY + 1
      CALL BTPCF(X,NX,FCN,LDF,NY,TX,KX,WORK,WORK(IW))
      CALL BTPCF(Y,NY,WORK,NY,NX,TY,KY,BCOEF,WORK(IW))
      GO TO 9999
C
C  -----
C  EXITS
C  -----
C
  920 CONTINUE
      CALL XERRWV('B2INK -   IFLAG=I1 IS OUT OF RANGE.',
     *            35,2,1,1,IFLAG,I2,0,R1,R2)
      IFLAG = 2
      GO TO 9999
C
  930 CONTINUE
      IFLAG = 3
      CALL XERRWV('B2INK -   NX=I1 IS OUT OF RANGE.',
     *            32,IFLAG,1,1,NX,I2,0,R1,R2)
      GO TO 9999
C
  940 CONTINUE
      IFLAG = 4
      CALL XERRWV('B2INK -   KX=I1 IS OUT OF RANGE.',
     *            32,IFLAG,1,1,KX,I2,0,R1,R2)
      GO TO 9999
C
  950 CONTINUE
      IFLAG = 5
      CALL XERRWV('B2INK -   X ARRAY MUST BE STRICTLY INCREASING.',
     *            46,IFLAG,1,0,I1,I2,0,R1,R2)
      GO TO 9999
C
  960 CONTINUE
      IFLAG = 6
      CALL XERRWV('B2INK -   TX ARRAY MUST BE NON-DECREASING.',
     *            42,IFLAG,1,0,I1,I2,0,R1,R2)
      GO TO 9999
C
  970 CONTINUE
      IFLAG = 7
      CALL XERRWV('B2INK -   NY=I1 IS OUT OF RANGE.',
     *            32,IFLAG,1,1,NY,I2,0,R1,R2)
      GO TO 9999
C
  980 CONTINUE
      IFLAG = 8
      CALL XERRWV('B2INK -   KY=I1 IS OUT OF RANGE.',
     *            32,IFLAG,1,1,KY,I2,0,R1,R2)
      GO TO 9999
C
  990 CONTINUE
      IFLAG = 9
      CALL XERRWV('B2INK -   Y ARRAY MUST BE STRICTLY INCREASING.',
     *            46,IFLAG,1,0,I1,I2,0,R1,R2)
      GO TO 9999
C
 1000 CONTINUE
      IFLAG = 10
      CALL XERRWV('B2INK -   TY ARRAY MUST BE NON-DECREASING.',
     *            42,IFLAG,1,0,I1,I2,0,R1,R2)
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BKNOT(X,N,K,T)
C***BEGIN PROLOGUE  BKNOT
C***REFER TO  B2INK,B3INK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***END PROLOGUE  BKNOT
C
C  --------------------------------------------------------------------
C  BKNOT CHOOSES A KNOT SEQUENCE FOR INTERPOLATION OF ORDER K AT THE
C  DATA POINTS X(I), I=1,..,N.  THE N+K KNOTS ARE PLACED IN THE ARRAY
C  T.  K KNOTS ARE PLACED AT EACH ENDPOINT AND NOT-A-KNOT END
C  CONDITIONS ARE USED.  THE REMAINING KNOTS ARE PLACED AT DATA POINTS
C  IF N IS EVEN AND BETWEEN DATA POINTS IF N IS ODD.  THE RIGHTMOST
C  KNOT IS SHIFTED SLIGHTLY TO THE RIGHT TO INSURE PROPER INTERPOLATION
C  AT X(N) (SEE PAGE 350 OF THE REFERENCE).
C  --------------------------------------------------------------------
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        N, K
      REAL
     *     X(N), T(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, J, IPJ, NPJ, IP1
      REAL
     *     RNOT
C
C
C  ----------------------------
C  PUT K KNOTS AT EACH ENDPOINT
C  ----------------------------
C
C     (SHIFT RIGHT ENPOINTS SLIGHTLY -- SEE PG 350 OF REFERENCE)
      RNOT = X(N) + 0.10E0*( X(N)-X(N-1) )
      DO 110 J=1,K
         T(J) = X(1)
         NPJ = N + J
         T(NPJ) = RNOT
  110 CONTINUE
C
C  --------------------------
C  DISTRIBUTE REMAINING KNOTS
C  --------------------------
C
      IF (MOD(K,2) .EQ. 1)  GO TO 150
C
C     CASE OF EVEN K --  KNOTS AT DATA POINTS
C
      I = (K/2) - K
      JSTRT = K+1
      DO 120 J=JSTRT,N
         IPJ = I + J
         T(J) = X(IPJ)
  120 CONTINUE
      GO TO 200
C
C     CASE OF ODD K --  KNOTS BETWEEN DATA POINTS
C
  150 CONTINUE
      I = (K-1)/2 - K
      IP1 = I + 1
      JSTRT = K + 1
      DO 160 J=JSTRT,N
         IPJ = I + J
         T(J) = 0.50E0*( X(IPJ) + X(IPJ+1) )
  160 CONTINUE
  200 CONTINUE
C
      RETURN
      END
      SUBROUTINE BTPCF(X,N,FCN,LDF,NF,T,K,BCOEF,WORK)
C***BEGIN PROLOGUE  BTPCF
C***REFER TO  B2INK,B3INK
C***ROUTINES CALLED  BINTK,BNSLV
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***END PROLOGUE  BTPCF
C
C  -----------------------------------------------------------------
C  BTPCF COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR NF SETS
C  OF DATA STORED IN THE COLUMNS OF THE ARRAY FCN. THE B-SPLINE
C  COEFFICIENTS ARE STORED IN THE ROWS OF BCOEF HOWEVER.
C  EACH INTERPOLATION IS BASED ON THE N ABCISSA STORED IN THE
C  ARRAY X, AND THE N+K KNOTS STORED IN THE ARRAY T. THE ORDER
C  OF EACH INTERPOLATION IS K. THE WORK ARRAY MUST BE OF LENGTH
C  AT LEAST 2*K*(N+1).
C  -----------------------------------------------------------------
C
C  ------------
C  DECLARATIONS
C  ------------
C
C  PARAMETERS
C
      INTEGER
     *        N, LDF, K
      REAL
     *     X(N), FCN(LDF,NF), T(*), BCOEF(NF,N), WORK(*)
C
C  LOCAL VARIABLES
C
      INTEGER
     *        I, J, K1, K2, IQ, IW
C
C  ---------------------------------------------
C  CHECK FOR NULL INPUT AND PARTITION WORK ARRAY
C  ---------------------------------------------
C
C***FIRST EXECUTABLE STATEMENT
      IF (NF .LE. 0)  GO TO 500
      K1 = K - 1
      K2 = K1 + K
      IQ = 1 + N
      IW = IQ + K2*N+1
C
C  -----------------------------
C  COMPUTE B-SPLINE COEFFICIENTS
C  -----------------------------
C
C
C   FIRST DATA SET
C
      CALL BINTK(X,FCN,T,N,K,WORK,WORK(IQ),WORK(IW))
      DO 20 I=1,N
         BCOEF(1,I) = WORK(I)
   20 CONTINUE
C
C  ALL REMAINING DATA SETS BY BACK-SUBSTITUTION
C
      IF (NF .EQ. 1)  GO TO 500
      DO 100 J=2,NF
         DO 50 I=1,N
            WORK(I) = FCN(I,J)
   50    CONTINUE
         CALL BNSLV(WORK(IQ),K2,N,K1,K1,WORK)
         DO 60 I=1,N
            BCOEF(J,I) = WORK(I)
   60    CONTINUE
  100 CONTINUE
C
C  ----
C  EXIT
C  ----
C
  500 CONTINUE
      RETURN
      END

      SUBROUTINE BINTK(X,Y,T,N,K,BCOEF,Q,WORK)
C***BEGIN PROLOGUE  BINTK
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  E1A
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Produces the B-spline coefficients, BCOEF, of the
C            B-spline of order K with knots T(I), I=1,...,N+K, which
C            takes on the value Y(I) at X(I), I=1,...,N.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     References
C
C          A Practical Guide to Splines by C. de Boor, Applied
C          Mathematics Series 27, Springer, 1979.
C
C     Abstract
C
C         BINTK is the SPLINT routine of the reference.
C
C         BINTK produces the B-spline coefficients, BCOEF, of the
C         B-spline of order K with knots T(I), I=1,...,N+K, which
C         takes on the value Y(I) at X(I), I=1,...,N.  The spline or
C         any of its derivatives can be evaluated by calls to BVALU.
C         The I-th equation of the linear system A*BCOEF = B for the
C         coefficients of the interpolant enforces interpolation at
C         X(I)), I=1,...,N.  Hence, B(I) = Y(I), all I, and A is
C         a band matrix with 2K-1 bands if A is invertible. The matrix
C         A is generated row by row and stored, diagonal by diagonal,
C         in the rows of Q, with the main diagonal going into row K.
C         The banded system is then solved by a call to BNFAC (which
C         constructs the triangular factorization for A and stores it
C         again in Q), followed by a call to BNSLV (which then
C         obtains the solution BCOEF by substitution). BNFAC does no
C         pivoting, since the total positivity of the matrix A makes
C         this unnecessary.  The linear system to be solved is
C         (theoretically) invertible if and only if
C                 T(I) .LT. X(I)) .LT. T(I+K),        all I.
C         Equality is permitted on the left for I=1 and on the right
C         for I=N when K knots are used at X(1) or X(N).  Otherwise,
C         violation of this condition is certain to lead to an error.
C
C         BINTK calls BSPVN, BNFAC, BNSLV, XERROR
C
C     Description of Arguments
C         Input
C           X       - vector of length N containing data point abscissa
C                     in strictly increasing order.
C           Y       - corresponding vector of length N containing data
C                     point ordinates.
C           T       - knot vector of length N+K
C                     since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K)
C                     .GE. X(N), this leaves only N-K knots (not nec-
C                     essarily X(I)) values) interior to (X(1),X(N))
C           N       - number of data points, N .GE. K
C           K       - order of the spline, K .GE. 1
C
C         Output
C           BCOEF   - a vector of length N containing the B-spline
C                     coefficients
C           Q       - a work vector of length (2*K-1)*N, containing
C                     the triangular factorization of the coefficient
C                     matrix of the linear system being solved.  The
C                     coefficients for the interpolant of an
C                     additional data set (X(I)),YY(I)), I=1,...,N
C                     with the same abscissa can be obtained by loading
C                     YY into BCOEF and then executing
C                         call BNSLV(Q,2K-1,N,K-1,K-1,BCOEF)
C           WORK    - work vector of length 2*K
C
C     Error Conditions
C         Improper  input is a fatal error
C         Singular system of equations is a fatal error
C***REFERENCES  D.E. AMOS, *COMPUTATION WITH SPLINES AND B-SPLINES*,
C                 SAND78-1968,SANDIA LABORATORIES,MARCH,1979.
C               C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C               C. DE BOOR, *A PRACTICAL GUIDE TO SPLINES*, APPLIED
C                 MATHEMATICS SERIES 27, SPRINGER, 1979.
C***ROUTINES CALLED  BNFAC,BNSLV,BSPVN,XERROR
C***END PROLOGUE  BINTK
C
C
      INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT,
     1 LENQ, NP1
      REAL BCOEF(N), Y(N), Q(*), T(*), X(N), XI, WORK(*)
C     DIMENSION Q(2*K-1,N), T(N+K)
C***FIRST EXECUTABLE STATEMENT  BINTK
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      JJ = N - 1
      IF(JJ.EQ.0) GO TO 6
      DO 5 I=1,JJ
      IF(X(I).GE.X(I+1)) GO TO 110
    5 CONTINUE
    6 CONTINUE
      NP1 = N + 1
      KM1 = K - 1
      KPKM2 = 2*KM1
      LEFT = K
C                ZERO OUT ALL ENTRIES OF Q
      LENQ = N*(K+KM1)
      DO 10 I=1,LENQ
        Q(I) = 0.0E0
   10 CONTINUE
C
C  ***   LOOP OVER I TO CONSTRUCT THE  N  INTERPOLATION EQUATIONS
      DO 50 I=1,N
        XI = X(I)
        ILP1MX = MIN0(I+K,NP1)
C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
C                T(LEFT) .LE. X(I) .LT. T(LEFT+1)
C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
        LEFT = MAX0(LEFT,I)
        IF (XI.LT.T(LEFT)) GO TO 80
   20   IF (XI.LT.T(LEFT+1)) GO TO 30
        LEFT = LEFT + 1
        IF (LEFT.LT.ILP1MX) GO TO 20
        LEFT = LEFT - 1
        IF (XI.GT.T(LEFT+1)) GO TO 80
C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE
C        A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE  K  ENTRIES WITH  J =
C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
C        ARE RETURNED, IN  BCOEF (USED FOR TEMP.STORAGE HERE), BY THE
C        FOLLOWING
   30   CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK)
C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO
C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J,  IF WE CONSIDER  Q
C        AS A TWO-DIM. ARRAY , WITH  2*K-1  ROWS (SEE COMMENTS IN
C        BNFAC). IN THE PRESENT PROGRAM, WE TREAT  Q  AS AN EQUIVALENT
C        ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON
C        DIMENSION STATEMENTS) . WE THEREFORE WANT  BCOEF(J) TO GO INTO
C        ENTRY
C            I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
C                   =  I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J
C        OF  Q .
        JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1)
        DO 40 J=1,K
          JJ = JJ + KPKM2
          Q(JJ) = BCOEF(J)
   40   CONTINUE
   50 CONTINUE
C
C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
      CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG)
      GO TO (60, 90), IFLAG
C     *** SOLVE  A*BCOEF = Y  BY BACKSUBSTITUTION
   60 DO 70 I=1,N
        BCOEF(I) = Y(I)
   70 CONTINUE
      CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF)
      RETURN
C
C
   80 CONTINUE
      CALL XERROR(  'BINTK,  SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE
     1 CORRESPONDING BASIS FUNCTION AND THE SYSTEM IS SINGULAR.',108,2,1
     2)
      RETURN
   90 CONTINUE
      CALL XERROR( 'BINTK,  THE SYSTEM OF SOLVER DETECTS A SINGULAR SYST
     1EM ALTHOUGH THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFI
     2ED.',121,8,1)
      RETURN
  100 CONTINUE
      CALL XERROR( ' BINTK,  K DOES NOT SATISFY K.GE.1', 34, 2, 1)
      RETURN
  105 CONTINUE
      CALL XERROR( ' BINTK,  N DOES NOT SATISFY N.GE.K', 34, 2, 1)
      RETURN
  110 CONTINUE
      CALL XERROR( ' BINTK,  X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SO
     1ME I', 56, 2, 1)
      RETURN
      END
      SUBROUTINE BNFAC(W,NROWW,NROW,NBANDL,NBANDU,IFLAG)
C***BEGIN PROLOGUE  BNFAC
C***REFER TO  BINT4,BINTK
C
C  BNFAC is the BANFAC routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Returns in  W  the lu-factorization (without pivoting) of the banded
C  matrix  A  of order  NROW  with  (NBANDL + 1 + NBANDU) bands or diag-
C  onals in the work array  W .
C
C *****  I N P U T  ******
C  W.....Work array of size  (NROWW,NROW)  containing the interesting
C        part of a banded matrix  A , with the diagonals or bands of  A
C        stored in the rows of  W , while columns of  A  correspond to
C        columns of  W . This is the storage mode used in  LINPACK  and
C        results in efficient innermost loops.
C           Explicitly,  A  has  NBANDL  bands below the diagonal
C                            +     1     (main) diagonal
C                            +   NBANDU  bands above the diagonal
C        and thus, with    MIDDLE = NBANDU + 1,
C          A(I+J,J)  is in  W(I+MIDDLE,J)  for I=-NBANDU,...,NBANDL
C                                              J=1,...,NROW .
C        For example, the interesting entries of A (1,2)-banded matrix
C        of order  9  would appear in the first  1+1+2 = 4  rows of  W
C        as follows.
C                          13 24 35 46 57 68 79
C                       12 23 34 45 56 67 78 89
C                    11 22 33 44 55 66 77 88 99
C                    21 32 43 54 65 76 87 98
C
C        All other entries of  W  not identified in this way with an en-
C        try of  A  are never referenced .
C  NROWW.....Row dimension of the work array  W .
C        must be  .GE.  NBANDL + 1 + NBANDU  .
C  NBANDL.....Number of bands of  A  below the main diagonal
C  NBANDU.....Number of bands of  A  above the main diagonal .
C
C *****  O U T P U T  ******
C  IFLAG.....Integer indicating success( = 1) or failure ( = 2) .
C     If  IFLAG = 1, then
C  W.....contains the LU-factorization of  A  into a unit lower triangu-
C        lar matrix  L  and an upper triangular matrix  U (both banded)
C        and stored in customary fashion over the corresponding entries
C        of  A . This makes it possible to solve any particular linear
C        system  A*X = B  for  X  by A
C              CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C        with the solution X  contained in  B  on return .
C     If  IFLAG = 2, then
C        one of  NROW-1, NBANDL,NBANDU failed to be nonnegative, or else
C        one of the potential pivots was found to be zero indicating
C        that  A  does not have an LU-factorization. This implies that
C        A  is singular in case it is totally positive .
C
C *****  M E T H O D  ******
C     Gauss elimination  W I T H O U T  pivoting is used. The routine is
C  intended for use with matrices  A  which do not require row inter-
C  changes during factorization, especially for the  T O T A L L Y
C  P O S I T I V E  matrices which occur in spline calculations.
C     The routine should not be used for an arbitrary banded matrix.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BNFAC
C
      INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K,
     1 KMAX, MIDDLE, MIDMK, NROWM1
      REAL W(NROWW,NROW), FACTOR, PIVOT
C
C***FIRST EXECUTABLE STATEMENT  BNFAC
      IFLAG = 1
      MIDDLE = NBANDU + 1
C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
      NROWM1 = NROW - 1
      IF (NROWM1) 120, 110, 10
   10 IF (NBANDL.GT.0) GO TO 30
C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
      DO 20 I=1,NROWM1
        IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120
   20 CONTINUE
      GO TO 110
   30 IF (NBANDU.GT.0) GO TO 60
C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
      DO 50 I=1,NROWM1
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
        JMAX = MIN0(NBANDL,NROW-I)
        DO 40 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   40   CONTINUE
   50 CONTINUE
      RETURN
C
C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
   60 DO 100 I=1,NROWM1
C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
C                     BELOW THE DIAGONAL .
        JMAX = MIN0(NBANDL,NROW-I)
C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
        DO 70 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   70   CONTINUE
C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
C                     THE RIGHT OF THE DIAGONAL .
        KMAX = MIN0(NBANDU,NROW-I)
C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
C                  (BELOW ROW  I ) .
        DO 90 K=1,KMAX
          IPK = I + K
          MIDMK = MIDDLE - K
          FACTOR = W(MIDMK,IPK)
          DO 80 J=1,JMAX
            W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
C                                       CHECK THE LAST DIAGONAL ENTRY .
  110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN
  120 IFLAG = 2
      RETURN
      END
      SUBROUTINE BNSLV(W,NROWW,NROW,NBANDL,NBANDU,B)
C***BEGIN PROLOGUE  BNSLV
C***REFER TO  BINT4,BINTK
C
C  BNSLV is the BANSLV routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Companion routine to  BNFAC . It returns the solution  X  of the
C  linear system  A*X = B  in place of  B , given the LU-factorization
C  for  A  in the work array  W from BNFAC.
C
C *****  I N P U T  ******
C  W, NROWW,NROW,NBANDL,NBANDU.....describe the LU-factorization of a
C        banded matrix  A  of order  NROW  as constructed in  BNFAC .
C        For details, see  BNFAC .
C  B.....Right side of the system to be solved .
C
C *****  O U T P U T  ******
C  B.....Contains the solution  X , of order  NROW .
C
C *****  M E T H O D  ******
C     (With  A = L*U, as stored in  W,) the unit lower triangular system
C  L(U*X) = B  is solved for  Y = U*X, and  Y  stored in  B . Then the
C  upper triangular system  U*X = Y  is solved for  X  . The calcul-
C  ations are so arranged that the innermost loops stay within columns.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  BNSLV
C
      INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1
      REAL W(NROWW,NROW), B(NROW)
C***FIRST EXECUTABLE STATEMENT  BNSLV
      MIDDLE = NBANDU + 1
      IF (NROW.EQ.1) GO TO 80
      NROWM1 = NROW - 1
      IF (NBANDL.EQ.0) GO TO 30
C                                 FORWARD PASS
C            FOR I=1,2,...,NROW-1, SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  L )  FROM RIGHT SIDE  (BELOW I-TH ROW) .
      DO 20 I=1,NROWM1
        JMAX = MIN0(NBANDL,NROW-I)
        DO 10 J=1,JMAX
          B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I)
   10   CONTINUE
   20 CONTINUE
C                                 BACKWARD PASS
C            FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG-
C            ONAL ENTRY OF  U, THEN SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  U)  FROM RIGHT SIDE  (ABOVE I-TH ROW).
   30 IF (NBANDU.GT.0) GO TO 50
C                                A  IS LOWER TRIANGULAR .
      DO 40 I=1,NROW
        B(I) = B(I)/W(1,I)
   40 CONTINUE
      RETURN
   50 I = NROW
   60 B(I) = B(I)/W(MIDDLE,I)
      JMAX = MIN0(NBANDU,I-1)
      DO 70 J=1,JMAX
        B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I)
   70 CONTINUE
      I = I - 1
      IF (I.GT.1) GO TO 60
   80 B(1) = B(1)/W(MIDDLE,1)
      RETURN
      END
      SUBROUTINE BSPVN(T,JHIGH,K,INDEX,X,ILEFT,VNIKX,WORK,IWORK)
C***BEGIN PROLOGUE  BSPVN
C***DATE WRITTEN   800901   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  E3,K6
C***KEYWORDS  B-SPLINE,DATA FITTING,INTERPOLATION,SPLINE
C***AUTHOR  AMOS, D. E., (SNLA)
C***PURPOSE  Calculates the value of all (possibly) nonzero basis
C            functions at X.
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Reference
C         SIAM J. Numerical Analysis, 14, No. 3, June, 1977, pp.441-472.
C
C     Abstract
C         BSPVN is the BSPLVN routine of the reference.
C
C         BSPVN calculates the value of all (possibly) nonzero basis
C         functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where
C         T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine
C         on the first call when INDEX=1.  ILEFT is such that T(ILEFT)
C         .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,ILO,ILEFT,
C         MFLAG) produces the proper ILEFT.  BSPVN calculates using the
C         basic algorithm needed in BSPVD.  If only basis functions are
C         desired, setting JHIGH=K and INDEX=1 can be faster than
C         calling BSPVD, but extra coding is required for derivatives
C         (INDEX=2) and BSPVD is set up for this purpose.
C
C         Left limiting values are set up as described in BSPVD.
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K, where
C                    N = number of B-spline basis functions
C                    N = sum of knot multiplicities-K
C          JHIGH   - order of B-spline, 1 .LE. JHIGH .LE. K
C          K       - highest possible order
C          INDEX   - INDEX = 1 gives basis functions of order JHIGH
C                          = 2 denotes previous entry with WORK, IWORK
C                              values saved for subsequent calls to
C                              BSPVN.
C          X       - argument of basis functions,
C                    T(K) .LE. X .LE. T(N+1)
C          ILEFT   - largest integer such that
C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
C
C         Output
C          VNIKX   - vector of length K for spline values.
C          WORK    - a work vector of length 2*K
C          IWORK   - a work parameter.  Both WORK and IWORK contain
C                    information necessary to continue for INDEX = 2.
C                    When INDEX = 1 exclusively, these are scratch
C                    variables and can be used for other purposes.
C
C     Error Conditions
C         Improper input is a fatal error.
C***REFERENCES  C. DE BOOR, *PACKAGE FOR CALCULATING WITH B-SPLINES*,
C                 SIAM JOURNAL ON NUMERICAL ANALYSIS, VOLUME 14, NO. 3,
C                 JUNE 1977, PP. 441-472.
C***ROUTINES CALLED  XERROR
C***END PROLOGUE  BSPVN
C
C
      INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L
      REAL T, VM, VMPREV, VNIKX, WORK, X
C     DIMENSION T(ILEFT+JHIGH)
      DIMENSION T(*), VNIKX(K), WORK(*)
C     CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS.
C     WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K
C***FIRST EXECUTABLE STATEMENT  BSPVN
      IF(K.LT.1) GO TO 90
      IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100
      IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105
      IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110
      GO TO (10, 20), INDEX
   10 IWORK = 1
      VNIKX(1) = 1.0E0
      IF (IWORK.GE.JHIGH) GO TO 40
C
   20 IPJ = ILEFT + IWORK
      WORK(IWORK) = T(IPJ) - X
      IMJP1 = ILEFT - IWORK + 1
      WORK(K+IWORK) = X - T(IMJP1)
      VMPREV = 0.0E0
      JP1 = IWORK + 1
      DO 30 L=1,IWORK
        JP1ML = JP1 - L
        VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML))
        VNIKX(L) = VM*WORK(L) + VMPREV
        VMPREV = VM*WORK(K+JP1ML)
   30 CONTINUE
      VNIKX(JP1) = VMPREV
      IWORK = JP1
      IF (IWORK.LT.JHIGH) GO TO 20
C
   40 RETURN
C
C
   90 CONTINUE
      CALL XERROR( ' BSPVN,  K DOES NOT SATISFY K.GE.1', 34, 2, 1)
      RETURN
  100 CONTINUE
      CALL XERROR( ' BSPVN,  JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K',
     1 47, 2, 1)
      RETURN
  105 CONTINUE
      CALL XERROR( ' BSPVN,  INDEX IS NOT 1 OR 2',28,2,1)
      RETURN
  110 CONTINUE
      CALL XERROR( ' BSPVN,  X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEFT
     1+1)', 55, 2, 1)
      RETURN
      END


			module funcs
			  implicit none
			contains
			  real function funcX(x)
				real, intent(in) :: x
				funcX = x*x
			  end function funcX
			end module funcs

			module mult
			  use funcs
			  contains
			  SUBROUTINE trapzd(func, a, b, s, n)
			  		  REAL func
					  EXTERNAL func
					  INTEGER n
					  REAL a, b, s

					  INTEGER it, j
					  REAL del, sum, tnm, x

					  if (n.eq.1) then
									s = 0.5*(b-a)*(func(a) + func(b))
					  else
									it = 2**(n-2)
									tnm=it
									del=(b-a)/tnm
									x=a+0.5*del
									sum = 0.
									do j = 1, it
														sum = sum + func(x)
														x = x + del
									end do
									s = 0.5*(s+(b-a)*sum/tnm)
					  endif
					  return
			  END SUBROUTINE trapzd

			  SUBROUTINE qsimp(a, b, s)
					  INTEGER JMAX
					  REAL a, b, s, EPS

					  PARAMETER (EPS=1.e-6, JMAX=20)

					  INTEGER j
					  REAL os, ost, st
					  ost=-1.e30
					  os=-1.e30
					  do j = 1, JMAX
								call trapzd(funcX, a, b, st, j)
								s=(4.*st-ost)/3.
								jj: if (j.gt.5) then
									kk: if (abs(s-os).lt.EPS*abs(os)) then
											 return
									end if kk
									mm: if (s.eq.0 .and. olds.eq.0) then
											return
									end if mm
								end if jj
								os = s
								ost = st
					 end do
			 END SUBROUTINE qsimp
			end module mult

			program funcargs
			  !use funcs
			  use mult
			  implicit none
			  real :: x
			  real :: v, s
			  x = 2
			  v = 3
			  call qsimp(x, v, s)
			  write (*,*) s
			end program funcargs


      real function crit(z,q)
c
c     + + + PURPOSE + + +
c
c     Function CRIT computes the critical flow depth.
c
c     Called from: SRS FRICHN, FSLPAR
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real z, q
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     z -
c     q -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcon.inc'
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      crit = (2.0*beta*q**2/(agrav*z**2)) ** 0.2
c
      return
      end


module derivative_stencil_module

  use iso_c_binding

  implicit none

  public

  integer, parameter :: stencil_ng = 4

  ! for 8th-order first derivatives
  double precision,dimension(4),parameter :: D8 = (/ 0.8d0, -0.2d0, 4.d0/105.d0, -1.d0/280.d0 /)

  ! coefficients for 8th-order stencil of second derivatives
  ! d(a*du/dx)/dx = H_{i+1/2} - H_{i-1/2},
  ! where H = a.M.u
  !
  double precision, save, dimension(8,8) :: M8, M8T
  !
  ! optimized for more zeros
  !  double precision, private, parameter :: M8_47 = 683.d0/10080.d0, M8_48 = -1.d0/224.d0
  !
  ! optimized for leading order truncation error assuming equal weight for the error terms
  double precision, private, parameter :: M8_47 = 3557.d0/44100.d0, M8_48 = -2083.d0/117600.d0

contains

  subroutine derivative_stencil_init () bind(c, name='derivative_stencil_init')

    ! 8th-order
    M8(1,1) = 5.d0/336.d0 + M8_48
    M8(2,1) = -11.d0/560.d0 - 2.d0*M8_48
    M8(3,1) = -1.d0/280.d0
    M8(4,1) = 17.d0/1680.d0 + 2.d0*M8_48
    M8(5,1) = -M8_48
    M8(6,1) = 0.d0
    M8(7,1) = 0.d0
    M8(8,1) = 0.d0

    M8(1,2) = -83.d0/3600.d0 - M8_47/5.d0 - 14.d0*M8_48/5.d0
    M8(2,2) = -31.d0/360.d0 + M8_47 + 3.d0*M8_48
    M8(3,2) = 1097.d0/5040.d0 - 2.d0*M8_47 + 6.d0*M8_48
    M8(4,2) = -319.d0/2520.d0 + 2.d0*M8_47 - 8.d0*M8_48
    M8(5,2) = -M8_47
    M8(6,2) = -139.d0/25200.d0 + M8_47/5.d0 + 9.d0*M8_48/5.d0
    M8(7,2) = 0.d0
    M8(8,2) = 0.d0

    M8(1,3) = 299.d0/50400.d0 + 2.d0*M8_47/5.d0 + 13.d0*M8_48/5.d0
    M8(2,3) = 41.d0/200.d0 - 9.d0*M8_47/5.d0 + 4.d0*M8_48/5.d0
    M8(3,3) = -1349.d0/10080.d0 + 3.d0*M8_47 - 12.d0*M8_48
    M8(4,3) = -919.d0/5040.d0 - 2.d0*M8_47 + 6.d0*M8_48
    M8(5,3) = 65.d0/224.d0 + 7.d0*M8_48
    M8(6,3) = -467.d0/25200.d0 + 3.d0*M8_47/5.d0 - 18.d0*M8_48/5.d0
    M8(7,3) = 503.d0/50400.d0 - M8_47/5.d0 - 4.d0*M8_48/5.d0
    M8(8,3) = 0.d0

    M8(1,4) = 17.d0/12600.d0 - M8_47/5.d0 - 4.d0*M8_48/5.d0
    M8(2,4) = -5927.d0/50400.d0 + 4.d0*M8_47/5.d0 - 9.d0*M8_48/5.d0
    M8(3,4) = -887.d0/5040.d0 - M8_47 + 6.d0*M8_48
    M8(4,4) = -445.d0/2016.d0
    M8(5,4) = -583.d0/720.d0 + M8_47 - 6.d0*M8_48
    M8(6,4) = -3613.d0/50400.d0 - 4.d0*M8_47/5.d0 + 9.d0*M8_48/5.d0
    M8(7,4) = -17.d0/600.d0 + M8_47/5.d0 + 4.d0*M8_48/5.d0
    M8(8,4) = -1.d0/1120.d0

    M8(1,5) = -M8(8,4)
    M8(2,5) = -M8(7,4)
    M8(3,5) = -M8(6,4)
    M8(4,5) = -M8(5,4)
    M8(5,5) = -M8(4,4)
    M8(6,5) = -M8(3,4)
    M8(7,5) = -M8(2,4)
    M8(8,5) = -M8(1,4)

    M8(1,6) = 0.d0
    M8(2,6) = -M8(7,3)
    M8(3,6) = -M8(6,3)
    M8(4,6) = -M8(5,3)
    M8(5,6) = -M8(4,3)
    M8(6,6) = -M8(3,3)
    M8(7,6) = -M8(2,3)
    M8(8,6) = -M8(1,3)

    M8(1,7) = 0.d0
    M8(2,7) = 0.d0
    M8(3,7) = -M8(6,2)
    M8(4,7) = -M8(5,2)
    M8(5,7) = -M8(4,2)
    M8(6,7) = -M8(3,2)
    M8(7,7) = -M8(2,2)
    M8(8,7) = -M8(1,2)

    M8(1,8) = 0.d0
    M8(2,8) = 0.d0
    M8(3,8) = 0.d0
    M8(4,8) = -M8(5,1)
    M8(5,8) = -M8(4,1)
    M8(6,8) = -M8(3,1)
    M8(7,8) = -M8(2,1)
    M8(8,8) = -M8(1,1)

    M8T = transpose(M8)

  end subroutine derivative_stencil_init

  function get_num_ghost_cells () result(r) bind(c, name='get_num_ghost_cells')
    integer :: r
    r = stencil_ng
  end function get_num_ghost_cells

end module derivative_stencil_module


      SUBROUTINE sla_GEOC (P, H, R, Z)
*+
*     - - - - -
*      G E O C
*     - - - - -
*
*  Convert geodetic position to geocentric (double precision)
*
*  Given:
*     P     dp     latitude (geodetic, radians)
*     H     dp     height above reference spheroid (geodetic, metres)
*
*  Returned:
*     R     dp     distance from Earth axis (AU)
*     Z     dp     distance from plane of Earth equator (AU)
*
*  Notes:
*     1)  Geocentric latitude can be obtained by evaluating ATAN2(Z,R).
*     2)  IAU 1976 constants are used.
*
*  Reference:
*     Green,R.M., Spherical Astronomy, CUP 1985, p98.
*
*  P.T.Wallace   Starlink   4th October 1989
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION P,H,R,Z

*  Earth equatorial radius (metres)
      DOUBLE PRECISION A0
      PARAMETER (A0=6378140D0)

*  Reference spheroid flattening factor and useful function
      DOUBLE PRECISION F,B
      PARAMETER (F=1D0/298.257D0,B=(1D0-F)**2)

*  Astronomical unit in metres
      DOUBLE PRECISION AU
      PARAMETER (AU=1.49597870D11)

      DOUBLE PRECISION SP,CP,C,S

*  Geodetic to geocentric conversion
      SP=SIN(P)
      CP=COS(P)
      C=1D0/SQRT(CP*CP+B*SP*SP)
      S=B*C
      R=(A0*C+H)*CP/AU
      Z=(A0*S+H)*SP/AU

      END


 SUBROUTINE POLATEV3(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,UI,VI, &
                     NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATEV3   INTERPOLATE VECTOR FIELDS (BUDGET)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR VECTOR FIELDS.
!           THE ALGORITHM SIMPLY COMPUTES (WEIGHTED) AVERAGES
!           OF BILINEARLY INTERPOLATED POINTS ARRANGED IN A SQUARE BOX
!           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
!           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
!           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
!           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
!           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
!           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
!           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
!           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!           A SPECIAL INTERPOLATION IS DONE IF IPOPT(2)=-2.
!           IN THIS CASE, THE BOXES STRETCH NEARLY ALL THE WAY TO
!           EACH OF THE NEIGHBORING GRID POINTS AND THE WEIGHTS
!           ARE THE ADJOINT OF THE BILINEAR INTERPOLATION WEIGHTS.
!           THIS CASE GIVES QUASI-SECOND-ORDER BUDGET INTERPOLATION.
!           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!
!           THE INPUT AND OUTPUT GRIDS ARE DEFINED BY THEIR GRIB 2 GRID
!           DEFINITION TEMPLATE AS DECODED BY THE NCEP G2 LIBRARY.  THE
!           CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!
!           THE INPUT AND OUTPUT VECTORS ARE ROTATED SO THAT THEY ARE
!           EITHER RESOLVED RELATIVE TO THE DEFINED GRID
!           IN THE DIRECTION OF INCREASING X AND Y COORDINATES
!           OR RESOLVED RELATIVE TO EASTERLY AND NORTHERLY DIRECTIONS,
!           AS DESIGNATED BY THEIR RESPECTIVE GRID DESCRIPTION SECTIONS.
!
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS AND
!           THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED
!           ALONG WITH THEIR VECTOR ROTATION PARAMETERS. ON THE OTHER
!           THE OUTPUT CAN BE A SET OF STATION POINTS IF
!           IGDTNUMO=IGDTNUMO-255, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 1999-04-08  IREDELL  ADDED BILINEAR OPTION IPOPT(2)=-2
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2002-01-17  IREDELL  SAVE DATA FROM LAST CALL FOR OPTIMIZATION
! 2006-01-05  GAYNO    ADDED OPTION TO TO DO SUBSECTION OF OUTPUT GRID.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      ROUTINE GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATEV3(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                     MI,MO,KM,IBI,LI,UI,VI, &
!                     NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS NUMBER OF RADIUS POINTS
!                (DEFAULTS TO 2 IF IPOPT(1)=-1);
!                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
!                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
!                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO=IGDTNUM-255
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     UI       - REAL (MI,KM) INPUT U-COMPONENT FIELDS TO INTERPOLATE
!     VI       - REAL (MI,KM) INPUT V-COMPONENT FIELDS TO INTERPOLATE
!     RLAT     - REAL (MO) INPUT LATITUDES IN DEGREES (IGDTNUMO<0)
!     RLON     - REAL (MO) INPUT LONGITUDES IN DEGREES (IGDTNUMO<0)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IGDTNUMO>=0)
!     CROT     - REAL (MO) VECTOR ROTATION COSINES
!     SROT     - REAL (MO) VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     UO       - REAL (MO,KM) OUTPUT U-COMPONENT FIELDS INTERPOLATED
!     VO       - REAL (MO,KM) OUTPUT V-COMPONENT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!                32   INVALID BUDGET METHOD PARAMETERS
!
! SUBPROGRAMS CALLED:
!   CHECK_GRIDS3V CHECK IF GRID SPECS HAVE CHANGED
!   GDSWZD        GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0       SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1       RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   MOVECT        MOVE A VECTOR ALONG A GREAT CIRCLE
!   POLFIXV       MAKE MULTIPLE POLE VECTOR VALUES CONSISTENT
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,          INTENT(IN   ) :: IPOPT(20), IBI(KM)
 INTEGER,          INTENT(IN   ) :: KM, MI, MO
 INTEGER,          INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,          INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,          INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,          INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
 INTEGER,          INTENT(  OUT) :: IRET, NO, IBO(KM)
!
 LOGICAL*1,        INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,        INTENT(  OUT) :: LO(MO,KM)
!
 REAL,             INTENT(IN   ) :: UI(MI,KM),VI(MI,KM)
 REAL,             INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,             INTENT(  OUT) :: UO(MO,KM),VO(MO,KM)
 REAL,             INTENT(  OUT) :: CROT(MO),SROT(MO)
!
 REAL,             PARAMETER     :: FILL=-9999.
!
 INTEGER                         :: IGDTNUMO2, IJKGDS1, IJKGDSA(20)
 INTEGER                         :: I1,I2,J1,J2,IB,JB,LSW,MP
 INTEGER,          SAVE          :: MIX=-1
 INTEGER                         :: K,LB,N,NB,NB1,NB2,NB3,NB4,NV
 INTEGER                         :: N11(MO),N21(MO),N12(MO),N22(MO)
!
 LOGICAL                         :: SAME_GRID
!
 REAL                            :: CM11,SM11,CM12,SM12
 REAL                            :: CM21,SM21,CM22,SM22
 REAL                            :: PMP,RB2
 REAL                            :: C11(MO),C21(MO),C12(MO),C22(MO)
 REAL                            :: S11(MO),S21(MO),S12(MO),S22(MO)
 REAL                            :: W11(MO),W21(MO),W12(MO),W22(MO)
 REAL                            :: UB,VB,WB,UROT,VROT
 REAL                            :: U11,V11,U21,V21,U12,V12,U22,V22
 REAL                            :: WI1,WJ1,WI2,WJ2
 REAL                            :: WO(MO,KM),XI,YI
 REAL                            :: XPTS(MO),YPTS(MO)
 REAL                            :: XPTB(MO),YPTB(MO),RLOB(MO),RLAB(MO)
 REAL,         ALLOCATABLE, SAVE :: CROI(:),SROI(:)
 REAL,         ALLOCATABLE, SAVE :: XPTI(:),YPTI(:),RLOI(:),RLAI(:)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
 IRET=0
 IF(IGDTNUMO.GE.0) THEN
   CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS, &
               RLON,RLAT,NO,CROT,SROT)
   IF(NO.EQ.0) IRET=3
 ELSE
   IGDTNUMO2=255+IGDTNUMO
   CALL GDSWZD(IGDTNUMO2,IGDTMPLO,IGDTLENO,-1,MO,FILL,XPTS,YPTS, &
               RLON,RLAT,NO,CROT,SROT)
   IF(NO.EQ.0) IRET=3
 ENDIF
 CALL CHECK_GRIDS3V(IGDTNUMI,IGDTMPLI,IGDTLENI,SAME_GRID)
 IF(.NOT.SAME_GRID) THEN
   IF(MIX.NE.MI) THEN
     IF(MIX.GE.0) DEALLOCATE(XPTI,YPTI,RLOI,RLAI,CROI,SROI)
     ALLOCATE(XPTI(MI),YPTI(MI),RLOI(MI),RLAI(MI),CROI(MI),SROI(MI))
     MIX=MI
   ENDIF
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI, 0,MI,FILL,XPTI,YPTI, &
               RLOI,RLAI,NV,CROI,SROI)
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 NB1=IPOPT(1)
 IF(NB1.EQ.-1) NB1=2
 IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
 LSW=1
 IF(IPOPT(2).EQ.-2) LSW=2
 IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
 IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
 MP=IPOPT(3+IPOPT(1))
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 IF(IRET.EQ.0) THEN
   NB2=2*NB1+1
   RB2=1./NB2
   NB3=NB2*NB2
   NB4=NB3
   IF(LSW.EQ.2) THEN
     RB2=1./(NB1+1)
     NB4=(NB1+1)**4
   ELSEIF(LSW.EQ.1) THEN
     NB4=IPOPT(2)
     DO IB=1,NB1
       NB4=NB4+8*IB*IPOPT(2+IB)
     ENDDO
   ENDIF
 ELSE
   NB3=0
   NB4=1
 ENDIF
 DO K=1,KM
   DO N=1,NO
     UO(N,K)=0
     VO(N,K)=0
     WO(N,K)=0.
   ENDDO
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
 CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
 DO NB=1,NB3
!  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS AND ROTATIONS
   JB=(NB-1)/NB2-NB1
   IB=NB-(JB+NB1)*NB2-NB1-1
   LB=MAX(ABS(IB),ABS(JB))
   WB=1
   IF(IPOPT(2).EQ.-2) THEN
     WB=(NB1+1-ABS(IB))*(NB1+1-ABS(JB))
   ELSEIF(IPOPT(2).NE.-1) THEN
     WB=IPOPT(2+LB)
   ENDIF
   IF(WB.NE.0) THEN
!$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
     DO N=1,NO
       XPTB(N)=XPTS(N)+IB*RB2
       YPTB(N)=YPTS(N)+JB*RB2
     ENDDO
!$OMP END PARALLEL DO
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 1,NO,FILL,XPTB,YPTB, &
                 RLOB,RLAB,NV)
     CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTB,YPTB, &
                 RLOB,RLAB,NV)
     IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
!$OMP PARALLEL DO PRIVATE(N,XI,YI,I1,I2,WI1,WI2,J1,J2,WJ1,WJ2,CM11,CM21,CM12,CM22,SM11,SM21,SM12,SM22) &
!$OMP SCHEDULE(STATIC)
     DO N=1,NO
       XI=XPTB(N)
       YI=YPTB(N)
       IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
         I1=XI
         I2=I1+1
         WI2=XI-I1
         WI1=1-WI2
         J1=YI
         J2=J1+1
         WJ2=YI-J1
         WJ1=1-WJ2
         N11(N)=IJKGDS1(I1,J1,IJKGDSA)
         N21(N)=IJKGDS1(I2,J1,IJKGDSA)
         N12(N)=IJKGDS1(I1,J2,IJKGDSA)
         N22(N)=IJKGDS1(I2,J2,IJKGDSA)
         IF(MIN(N11(N),N21(N),N12(N),N22(N)).GT.0) THEN
           W11(N)=WI1*WJ1
           W21(N)=WI2*WJ1
           W12(N)=WI1*WJ2
           W22(N)=WI2*WJ2
           CALL MOVECT(RLAI(N11(N)),RLOI(N11(N)),RLAT(N),RLON(N),CM11,SM11)
           CALL MOVECT(RLAI(N21(N)),RLOI(N21(N)),RLAT(N),RLON(N),CM21,SM21)
           CALL MOVECT(RLAI(N12(N)),RLOI(N12(N)),RLAT(N),RLON(N),CM12,SM12)
           CALL MOVECT(RLAI(N22(N)),RLOI(N22(N)),RLAT(N),RLON(N),CM22,SM22)
           C11(N)=CM11*CROI(N11(N))+SM11*SROI(N11(N))
           S11(N)=SM11*CROI(N11(N))-CM11*SROI(N11(N))
           C21(N)=CM21*CROI(N21(N))+SM21*SROI(N21(N))
           S21(N)=SM21*CROI(N21(N))-CM21*SROI(N21(N))
           C12(N)=CM12*CROI(N12(N))+SM12*SROI(N12(N))
           S12(N)=SM12*CROI(N12(N))-CM12*SROI(N12(N))
           C22(N)=CM22*CROI(N22(N))+SM22*SROI(N22(N))
           S22(N)=SM22*CROI(N22(N))-CM22*SROI(N22(N))
         ELSE
           N11(N)=0
           N21(N)=0
           N12(N)=0
           N22(N)=0
         ENDIF
       ELSE
         N11(N)=0
         N21(N)=0
         N12(N)=0
         N22(N)=0
       ENDIF
     ENDDO
!$OMP END PARALLEL DO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE WITH OR WITHOUT BITMAPS
!  KM IS OFTEN 1 .. DO NO PUT OMP PARALLEL DO HERE
     DO K=1,KM
!$OMP PARALLEL DO PRIVATE(N,U11,U12,U21,U22,UB,V11,V12,V21,V22,VB) SCHEDULE(STATIC)
       DO N=1,NO
         IF(N11(N).GT.0) THEN
           IF(IBI(K).EQ.0) THEN
             U11=C11(N)*UI(N11(N),K)-S11(N)*VI(N11(N),K)
             V11=S11(N)*UI(N11(N),K)+C11(N)*VI(N11(N),K)
             U21=C21(N)*UI(N21(N),K)-S21(N)*VI(N21(N),K)
             V21=S21(N)*UI(N21(N),K)+C21(N)*VI(N21(N),K)
             U12=C12(N)*UI(N12(N),K)-S12(N)*VI(N12(N),K)
             V12=S12(N)*UI(N12(N),K)+C12(N)*VI(N12(N),K)
             U22=C22(N)*UI(N22(N),K)-S22(N)*VI(N22(N),K)
             V22=S22(N)*UI(N22(N),K)+C22(N)*VI(N22(N),K)
             UB=W11(N)*U11+W21(N)*U21+W12(N)*U12+W22(N)*U22
             VB=W11(N)*V11+W21(N)*V21+W12(N)*V12+W22(N)*V22
             UO(N,K)=UO(N,K)+WB*UB
             VO(N,K)=VO(N,K)+WB*VB
             WO(N,K)=WO(N,K)+WB
           ELSE
             IF(LI(N11(N),K)) THEN
               U11=C11(N)*UI(N11(N),K)-S11(N)*VI(N11(N),K)
               V11=S11(N)*UI(N11(N),K)+C11(N)*VI(N11(N),K)
               UO(N,K)=UO(N,K)+WB*W11(N)*U11
               VO(N,K)=VO(N,K)+WB*W11(N)*V11
               WO(N,K)=WO(N,K)+WB*W11(N)
             ENDIF
             IF(LI(N21(N),K)) THEN
               U21=C21(N)*UI(N21(N),K)-S21(N)*VI(N21(N),K)
               V21=S21(N)*UI(N21(N),K)+C21(N)*VI(N21(N),K)
               UO(N,K)=UO(N,K)+WB*W21(N)*U21
               VO(N,K)=VO(N,K)+WB*W21(N)*V21
               WO(N,K)=WO(N,K)+WB*W21(N)
             ENDIF
             IF(LI(N12(N),K)) THEN
               U12=C12(N)*UI(N12(N),K)-S12(N)*VI(N12(N),K)
               V12=S12(N)*UI(N12(N),K)+C12(N)*VI(N12(N),K)
               UO(N,K)=UO(N,K)+WB*W12(N)*U12
               VO(N,K)=VO(N,K)+WB*W12(N)*V12
               WO(N,K)=WO(N,K)+WB*W12(N)
             ENDIF
             IF(LI(N22(N),K)) THEN
               U22=C22(N)*UI(N22(N),K)-S22(N)*VI(N22(N),K)
               V22=S22(N)*UI(N22(N),K)+C22(N)*VI(N22(N),K)
               UO(N,K)=UO(N,K)+WB*W22(N)*U22
               VO(N,K)=VO(N,K)+WB*W22(N)*V22
               WO(N,K)=WO(N,K)+WB*W22(N)
             ENDIF
           ENDIF
         ENDIF
       ENDDO
!$OMP END PARALLEL DO
     ENDDO
   ENDIF
 ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE OUTPUT BITMAPS AND FIELDS
! KM is often 1, do not put OMP PARALLEL here
 DO K=1,KM
   IBO(K)=IBI(K)
!$OMP PARALLEL DO PRIVATE(N,UROT,VROT) SCHEDULE(STATIC)
   DO N=1,NO
     LO(N,K)=WO(N,K).GE.PMP*NB4
     IF(LO(N,K)) THEN
       UO(N,K)=UO(N,K)/WO(N,K)
       VO(N,K)=VO(N,K)/WO(N,K)
       UROT=CROT(N)*UO(N,K)-SROT(N)*VO(N,K)
       VROT=SROT(N)*UO(N,K)+CROT(N)*VO(N,K)
       UO(N,K)=UROT
       VO(N,K)=VROT
     ELSE
       IBO(K)=1
       UO(N,K)=0.
       VO(N,K)=0.
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
 ENDDO
 IF(IGDTNUMO.EQ.0) CALL POLFIXV(NO,MO,KM,RLAT,RLON,IBO,LO,UO,VO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATEV3
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE CHECK_GRIDS3V(IGDTNUM,IGDTMPL,IGDTLEN,SAME_GRID)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS3V   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS3V(IGDTNUM,IGDTMPL,IGDTLEN,SAME_GRID)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!               CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!               NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPL - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY.
!               CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!               OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLEN - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!               TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!               COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRID  - WHEN TRUE, THE GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,        INTENT(IN   ) :: IGDTMPL(IGDTLEN)
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRID
!
 INTEGER, SAVE                 :: IGDTNUM_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLEN_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPL_SAVE(1000)=-9999
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRID=.FALSE.
 IF(IGDTNUM==IGDTNUM_SAVE)THEN
   IF(IGDTLEN==IGDTLEN_SAVE)THEN
     IF(ALL(IGDTMPL==IGDTMPL_SAVE(1:IGDTLEN)))THEN
       SAME_GRID=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUM_SAVE=IGDTNUM
 IGDTLEN_SAVE=IGDTLEN
 IGDTMPL_SAVE(1:IGDTLEN)=IGDTMPL
 IGDTMPL_SAVE(IGDTLEN+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS3V


program tri_ppal

implicit none

real, dimension(:), allocatable :: a,b,c,r,w,u

integer :: n, i, j

print*, 'Introduce o orde do sistema: '
read*, n
print*
print*, 'O orde introducido e: ', n
print*

allocate(a(n), b(2:n), r(n), w(n), u(n))

print*,
print*, 'Introduce a diagonal principal: '
read*, a(1:n)
print*,

print*,
print*, 'Introduce a diagonal inferior: '
read*, b(2:n)
print*,

print*, 'Introduce el segundo miembro: '
read*, r(1:n)
print*,

print*,
print*, 'Diagonal principal: ',a(1:n)
print*, 'Diagonal inferior ', b(2:n)
print*, 'Segundo miembro: ',r(1:n)
print*,

a(1) = sqrt(a(1))

do i=2,n
  b(i) = b(i)/a(i-1)
  a(i) = sqrt(a(i)-b(i)*b(i))
end do

print*,
print*, 'Diagonal principal: ',a(1:n)
print*, 'Diagonal inferior ', b(2:n)
print*, 'Segundo miembro: ',r(1:n)
print*,

w(1) = r(1)/a(1)

do i=2,n
print*, r(i)
print*, w(i-1)
print*, a(i)
  w(i)=(r(i)- b(i)*w(i-1))/a(i)
end do

print*, 'Vector w:'
print*, w
print*,

u(n) = w(n)/a(n)

do i=n-1,1,-1
  u(i)= (w(i)-b(i+1)*u(i+1))/a(i)
end do

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

end program


      REAL             FUNCTION SNRM2F ( N, X, INCX )
*     .. Scalar Arguments ..
      INTEGER                           INCX, N
*     .. Array Arguments ..
      REAL                              X( * )
*     ..
*
*  SNRM2 returns the euclidean norm of a vector via the function
*  name, so that
*
*     SNRM2 := sqrt( x'*x )
*
*
*
*  -- This version written on 25-October-1982.
*     Modified on 14-October-1993 to inline the call to SLASSQ.
*     Sven Hammarling, Nag Ltd.
*
*
*     .. Parameters ..
      REAL                  ONE         , ZERO
      PARAMETER           ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     .. Local Scalars ..
      INTEGER               IX
      REAL                  ABSXI, NORM, SCALE, SSQ
*     .. Intrinsic Functions ..
      INTRINSIC             ABS, SQRT
*     ..
*     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL SLASSQ( N, X, INCX, SCALE, SSQ )
*
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ   +     ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
*
      SNRM2F = NORM
      RETURN
*
*     End of SNRM2.
*
      END


    Program dgecon_example

!     DGECON Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgecon, dgetrf, dlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: norm = '1'
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, rcond
      Integer :: i, info, lda, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), work(:)
      Integer, Allocatable :: ipiv(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DGECON Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      Allocate (a(lda,n), work(4*n), ipiv(n), iwork(n))

!     Read A from data file

      Read (nin, *)(a(i,1:n), i=1, n)

!     Compute norm of A

      anorm = dlange(norm, n, n, a, lda, work)

!     Factorize A
      Call dgetrf(n, n, a, lda, ipiv, info)

      Write (nout, *)
      If (info==0) Then

!       Estimate condition number

        Call dgecon(norm, n, a, lda, anorm, rcond, work, iwork, info)

        If (rcond>=epsilon(1.0E0_dp)) Then
          Write (nout, 100) 'Estimate of condition number =', 1.0E0_dp/rcond
        Else
          Write (nout, *) 'A is singular to working precision'
        End If
      Else
        Write (nout, *) 'The factor U is singular'
      End If

100   Format (1X, A, 1P, E10.2)
    End Program


subroutine line(a,b,n,v)
implicit none;
 integer ::i,n ;
 real*8::a,b;
 real*8,dimension(n)::v;
v=(/((a+(b-a)/(n-1)*i),i=0,n-1)/);
return;
end subroutine


   SUBROUTINE inverse(a,c,n)
   !============================================================
   ! Inverse matrix
   ! Method: Based on Doolittle LU factorization for Ax=b
   ! Alex G. December 2009
   !-----------------------------------------------------------
   ! input ...
   ! a(n,n) - array of coefficients for matrix A
   ! n      - dimension
   ! output ...
   ! c(n,n) - inverse matrix of A
   ! comments ...
   ! the original matrix a(n,n) will be destroyed
   ! during the calculation
   !===========================================================
   implicit none
   integer n
   double precision a(n,n),c(n,n)
   double precision L(n,n),U(n,n), b(n), d(n), x(n)
   double precision coeff
   integer i, j, k

   ! step 0: initialization for matrices L and U and b
   ! Fortran 90/95 aloows such operations on matrices
   L=0.0d0
   U=0.0d0
   b=0.0d0

   ! step 1: forward elimination
   do k=1, n-1
      do i=k+1,n
         coeff=a(i,k)/a(k,k)
         L(i,k) = coeff
         do j=k+1,n
            a(i,j) = a(i,j)-coeff*a(k,j)
         end do
       end do
   end do

   ! Step 2: prepare L and U matrices
   ! L matrix is a matrix of the elimination coefficient
   ! + the diagonal elements are 1.0
   do i=1,n
      L(i,i) = 1.0d0
   end do
   ! U matrix is the upper triangular part of A
   do j=1,n
      do i=1,j
         U(i,j) = a(i,j)
      end do
   end do

   ! Step 3: compute columns of the inverse matrix C
   do k=1,n
      b(k)=1.0d0
      d(1) = b(1)
   ! Step 3a: Solve Ld=b using the forward substitution
      do i=2,n
         d(i)=b(i)
         do j=1,i-1
            d(i) = d(i) - L(i,j)*d(j)
         end do
      end do
   ! Step 3b: Solve Ux=d using the back substitution
      x(n)=d(n)/U(n,n)
      do i = n-1,1,-1
         x(i) = d(i)
         do j=n,i+1,-1
            x(i)=x(i)-U(i,j)*x(j)
         end do
         x(i) = x(i)/u(i,i)
      end do
   ! Step 3c: fill the solutions x(n) into column k of C
      do i=1,n
         c(i,k) = x(i)
      end do
      b(k)=0.0d0
   end do

   END SUBROUTINE inverse


module libMath

  implicit none
  integer, parameter :: dp = kind(1.d0)
  real(dp), parameter :: pi = atan(1._dp)*4._dp
  real(dp), parameter :: eps = epsilon(1._dp)

contains

  ! -------------------------------------------------
  !                cross3
  ! -------------------------------------------------
  function cross3(avec,bvec)
    real(dp), intent(in), dimension(3) :: avec,bvec
    real(dp), dimension(3) :: cross3

    cross3(1) = avec(2)*bvec(3)-avec(3)*bvec(2)
    cross3(2) = avec(3)*bvec(1)-avec(1)*bvec(3)
    cross3(3) = avec(1)*bvec(2)-avec(2)*bvec(1)

  end function cross3

  ! -------------------------------------------------
  !                linspace
  ! -------------------------------------------------
  function linspace(xstart,xend,nx) result(xout)
    real(dp), intent(in) :: xstart, xend
    integer , intent(in) :: nx
    real(dp), dimension(nx) :: xout
    integer :: i
    real(dp) :: dx

    dx = (xend-xstart)/(nx-1)

    xout = (/((i*dx),i=0,nx-1)/)
    xout = xout+xstart

  end function linspace

  ! -------------------------------------------------
  !                cosspace
  ! -------------------------------------------------
  function cosspace(xstart,xend,nx) result(xout)
    real(dp), intent(in) :: xstart, xend
    integer , intent(in) :: nx
    real(dp), dimension(nx) :: xout
    real(dp), dimension(nx) :: theta_spacing

    theta_spacing=linspace(0._dp,pi,nx)
    xout=xstart+(xend-xstart)*0.5_dp*(1._dp-cos(theta_spacing))

  end function cosspace

  ! -------------------------------------------------
  !                halfsinspace
  ! -------------------------------------------------
  function halfsinspace(xstart,xend,nx) result(xout)
    real(dp), intent(in) :: xstart, xend
    integer , intent(in) :: nx
    real(dp), dimension(nx) :: xout
    real(dp), dimension(nx) :: theta_spacing

    theta_spacing=linspace(0._dp,pi*0.5_dp,nx)
    xout=xstart+(xend-xstart)*sin(theta_spacing)

  end function halfsinspace

end module libMath


program main
! The main program for MD.
!
!  Discussion:
!    MD implements a simple molecular dynamics simulation.
!    The velocity Verlet time integration scheme is used.
!    The particles interact with a central pair potential.
!
!    Based on a FORTRAN90 program by Bill Magro.
!
!    Calculating distances, forces, potential- and kinetic-
!    energies have been broken out into subroutines to make this
!    a more interesting example to analyze with a profiler.
!    2018-05-25 Oliver Stueker
!
!  Usage:
!    md nd np step_num dt
!
!    where:
!
!    * nd is the spatial dimension (2 or 3);
!    * np is the number of particles (500, for instance);
!    * step_num is the number of time steps (500, for instance).
!    * dt is the time step (0.1 for instance )
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    25 May 2018 by Oliver Stueker
!
!  Author:
!    John Burkardt
!
  implicit none

  real ( kind = 8 ), allocatable :: acc(:,:)
  integer ( kind = 4 ) arg_num
  real ( kind = 8 ) ctime
  real ( kind = 8 ) ctime1
  real ( kind = 8 ) ctime2
  real ( kind = 8 ) dt
  real ( kind = 8 ) e0
  real ( kind = 8 ), allocatable :: force(:,:)
  integer ( kind = 4 ) iarg
  integer ( kind = 4 ) id
  integer ( kind = 4 ) ierror
  real ( kind = 8 ) kinetic
  integer ( kind = 4 ) last
  real ( kind = 8 ), parameter :: mass = 1.0D+00
  integer ( kind = 4 ) nd
  integer ( kind = 4 ) np
  real ( kind = 8 ), allocatable :: pos(:,:)
  real ( kind = 8 ) potential
  real ( kind = 8 ) rel
  integer ( kind = 4 ) step
  integer ( kind = 4 ) step_num
  integer ( kind = 4 ) step_print
  integer ( kind = 4 ) step_print_index
  integer ( kind = 4 ) step_print_num
  character ( len = 255 ) string
  real ( kind = 8 ), allocatable :: vel(:,:)
  real ( kind = 8 ) wtime

  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) '  A molecular dynamics program.'
!
!  Get the number of command line arguments.
!
  arg_num = iargc ( )
!
!  Get ND, the number of spatial dimensions.
!
  if ( 1 <= arg_num ) then
    iarg = 1
    call getarg ( iarg, string )
    call s_to_i4 ( string, nd, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Enter ND, the spatial dimension (2 or 3 ):'
    read ( *, * ) nd
  end if
!
!  Get NP, the number of particles.
!
  if ( 2 <= arg_num ) then
    iarg = 2
    call getarg ( iarg, string )
    call s_to_i4 ( string, np, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter NP, the number of particles (500, for instance):'
    read ( *, * ) np
  end if
!
!  Get STEP_NUM, the number of time steps.
!
  if ( 3 <= arg_num ) then
    iarg = 3
    call getarg ( iarg, string )
    call s_to_i4 ( string, step_num, ierror, last )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter STEP_NUM, the number of time steps (500, for instance):'
    read ( *, * ) step_num
  end if
!
!  Get DT, the time step.
!
  if ( 4 <= arg_num ) then
    iarg = 4
    call getarg ( iarg, string )
    call s_to_r8 ( string, dt  )
  else
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) &
      '  Enter DT, the time step size (0.1, for instance):'
    read ( *, * ) dt
  end if
!
!  Report.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) '  ND, the spatial dimension, is ', nd
  write ( *, '(a,i8)' ) &
    '  NP, the number of particles in the simulation is ', np
  write ( *, '(a,i8)' ) '  STEP_NUM, the number of time steps, is ', step_num
  write ( *, '(a,g14.6)' ) '  DT, the size of each time step, is ', dt
!
!  Allocate memory.
!
  allocate ( acc(nd,np) )
  allocate ( force(nd,np) )
  allocate ( pos(nd,np) )
  allocate ( vel(nd,np) )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '  At each step, we report the potential and kinetic energies.'
  write ( *, '(a)' ) '  The sum of these energies should be a constant.'
  write ( *, '(a)' ) '  As an accuracy check, we also print the relative error'
  write ( *, '(a)' ) '  in the total energy.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '      Step      Potential       Kinetic        (P+K-E0)/E0'
  write ( *, '(a)' ) &
    '                Energy P        Energy K       Relative Energy Error'
  write ( *, '(a)' ) ' '
!
!  This is the main time stepping loop:
!    Initialize or update positions, velocities, accelerations.
!    Compute forces and energies,
!
  step_print = 0
  step_print_index = 0
  step_print_num = 10

  call cpu_time ( ctime1 )

  do step = 0, step_num

    if ( step == 0 ) then
      call initialize ( np, nd, pos, vel, acc )
    else
      call update ( np, nd, pos, vel, force, acc, mass, dt )
    end if

    call compute ( np, nd, pos, vel, mass, force, potential, kinetic )

    if ( step == 0 ) then
      e0 = potential + kinetic
    end if

    if ( step == step_print ) then
      rel = ( potential + kinetic - e0 ) / e0
      write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,g14.6)' ) &
        step, potential, kinetic, rel
      step_print_index = step_print_index + 1
      step_print = ( step_print_index * step_num ) / step_print_num
    end if

  end do
!
!  Report time.
!
  call cpu_time ( ctime2 )
  ctime = ctime2 - ctime1
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Elapsed cpu time for main computation:'
  write ( *, '(2x,g14.6,a)' ) ctime, ' seconds'
!
!  Free memory.
!
  deallocate ( acc )
  deallocate ( force )
  deallocate ( pos )
  deallocate ( vel )
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MD:'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end

!*****************************************************************************80
subroutine compute ( np, nd, pos, vel, mass, f, pot, kin )
! Computes the forces and energies.
!
!  Discussion:
!    The computation of forces and energies is fully parallel.
!
!    The potential function V(X) is a harmonic well which smoothly
!    saturates to a maximum value at PI/2:
!
!      v(x) = ( sin ( min ( x, PI/2 ) ) )^2
!
!    The derivative of the potential is:
!
!      dv(x) = 2.0D+00 * sin ( min ( x, PI/2 ) ) * cos ( min ( x, PI/2 ) )
!            = sin ( 2.0 * min ( x, PI/2 ) )
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    15 July 2008
!
!  Author:
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Input, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Input, real ( kind = 8 ) MASS, the mass.
!
!    Output, real ( kind = 8 ) F(ND,NP), the forces.
!
!    Output, real ( kind = 8 ) POT, the total potential energy.
!
!    Output, real ( kind = 8 ) KIN, the total kinetic energy.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) d
  real ( kind = 8 ) d2
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) kin
  real ( kind = 8 ) mass
  real ( kind = 8 ), parameter :: PI2 = 3.141592653589793D+00 / 2.0D+00
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) pot
  real ( kind = 8 ) rij(nd)
  real ( kind = 8 ) vel(nd,np)

  pot = 0.0D+00

  do i = 1, np
    !
    !  Compute the potential energy and forces.
    !
    f(1:nd,i) = 0.0D+00

    do j = 1, np

      if ( i /= j ) then

        call calc_distance (np, nd, pos, i, j, rij, d, d2)

        call calc_pot(d2, pot)

        call calc_force (np, nd, i, d, d2, rij, f)

      end if

    end do

  end do

  call calc_kin ( np, nd, vel, mass, kin )

  return
end

subroutine calc_pot (d2, pot)
!  Calculate potential energy for truncated distance D2.
!
!  Parameters:
!    Input,  real ( kind = 8 ) D2,  trucated distance.
!    In/Out, real ( kind = 8 ) POT, potential energy.
    implicit none

    real ( kind = 8 ) d2
    real ( kind = 8 ) pot

    !
    !  Attribute half of the total potential energy to particle J.
    !
    pot = pot + 0.5D+00 * sin ( d2 ) * sin ( d2 )
end subroutine calc_pot

subroutine calc_force (np, nd, i, d, d2, rij, f)
!  Add particle J's contribution to the force on particle I.
!
!  Parameters:
!    Input,  integer ( kind = 4 ) NP, the number of particles.
!    Input,  integer ( kind = 4 ) ND, the number of spatial dimensions.
!    Input,  integer ( kind = 4 ) I,  index of particle I.
!    Input,  real ( kind = 8 )    D, distance.
!    Input,  real ( kind = 8 )    D2, trucated distance.
!    Input,  real ( kind = 8 )    Rij(nd),  distance vector
!    In/Out, real ( kind = 8 )    F(ND,NP), the forces.
    implicit none

    integer ( kind = 4 ) np
    integer ( kind = 4 ) nd
    integer ( kind = 4 ) i

    real ( kind = 8 ) d
    real ( kind = 8 ) d2
    real ( kind = 8 ) rij(nd)
    real ( kind = 8 ) f(nd,np)
    !
    !  Add particle J's contribution to the force on particle I.
    !
    f(1:nd,i) = f(1:nd,i) - rij(1:nd) * sin ( 2.0D+00 * d2 ) / d
end subroutine calc_force

subroutine calc_kin ( np, nd, vel, mass, kin )
!  Compute the total kinetic energy.
!
!  Parameters:
!    Input,  integer ( kind = 4 ) NP, the number of particles.
!    Input,  integer ( kind = 4 ) ND, the number of spatial dimensions.
!    Input,  real ( kind = 8 ) VEL(ND,NP), the velocities.
!    Input,  real ( kind = 8 ) MASS, the mass.
!    Output, real ( kind = 8 ) KIN, the total kinetic energy.
    implicit none

    integer ( kind = 4 ) np
    integer ( kind = 4 ) nd
    real ( kind = 8 ) vel(nd,np)
    real ( kind = 8 ) mass
    real ( kind = 8 ) kin

    kin = 0.5D+00 * mass * sum ( vel(1:nd,1:np)**2 )

end subroutine calc_kin

!*****************************************************************************80
subroutine initialize ( np, nd, pos, vel, acc )
! Initializes the positions, velocities, and accelerations.
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    26 December 2014
!
!  Author:
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Output, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Output, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Output, real ( kind = 8 ) ACC(ND,NP), the accelerations.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) pos(nd,np)
  integer ( kind = 4 ) seed
  real ( kind = 8 ) vel(nd,np)
!
!  Set the positions.
!
  seed = 123456789
  call r8mat_uniform_ab ( nd, np, 0.0D+00, 10.0D+00, seed, pos )
!
!  Set the velocities.
!
  vel(1:nd,1:np) = 0.0D+00
!
!  Set the accelerations.
!
  acc(1:nd,1:np) = 0.0D+00

  return
end

!*****************************************************************************80
subroutine update ( np, nd, pos, vel, f, acc, mass, dt )
! Updates positions, velocities and accelerations.
!
!  Discussion:
!    The time integration is fully parallel.
!
!    A velocity Verlet algorithm is used for the updating.
!
!    x(t+dt) = x(t) + v(t) * dt + 0.5 * a(t) * dt * dt
!    v(t+dt) = v(t) + 0.5 * ( a(t) + a(t+dt) ) * dt
!    a(t+dt) = f(t) / m
!
!  Licensing:
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!    21 November 2007
!
!  Author:
!    John Burkardt
!
!  Parameters:
!    Input, integer ( kind = 4 ) NP, the number of particles.
!
!    Input, integer ( kind = 4 ) ND, the number of spatial dimensions.
!
!    Input/output, real ( kind = 8 ) POS(ND,NP), the positions.
!
!    Input/output, real ( kind = 8 ) VEL(ND,NP), the velocities.
!
!    Input, real ( kind = 8 ) F(ND,NP), the forces.
!
!    Input/output, real ( kind = 8 ) ACC(ND,NP), the accelerations.
!
!    Input, real ( kind = 8 ) MASS, the mass of each particle.
!
!    Input, real ( kind = 8 ) DT, the time step.
!
  implicit none

  integer ( kind = 4 ) np
  integer ( kind = 4 ) nd

  real ( kind = 8 ) acc(nd,np)
  real ( kind = 8 ) dt
  real ( kind = 8 ) f(nd,np)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  real ( kind = 8 ) mass
  real ( kind = 8 ) pos(nd,np)
  real ( kind = 8 ) rmass
  real ( kind = 8 ) vel(nd,np)

  rmass = 1.0D+00 / mass

  do j = 1, np
    do i = 1, nd
      pos(i,j) = pos(i,j) + vel(i,j) * dt + 0.5D+00 * acc(i,j) * dt * dt
      vel(i,j) = vel(i,j) + 0.5D+00 * dt * ( f(i,j) * rmass + acc(i,j) )
      acc(i,j) = f(i,j) * rmass
    end do
  end do

  return
end


      PROGRAM xsprstp
C     driver for routine sprstp
      INTEGER NP,NMAX
      PARAMETER(NP=5,NMAX=2*NP*NP+1)
      INTEGER i,j,ija(NMAX),ijat(NMAX)
      REAL a(NP,NP),at(NP,NP),sa(NMAX),sat(NMAX)
      DATA a/3.0,0.0,0.0,0.0,0.0,
     *     0.0,4.0,7.0,0.0,0.0,
     *     1.0,0.0,5.0,0.0,0.0,
     *     0.0,0.0,9.0,0.0,6.0,
     *     0.0,0.0,0.0,2.0,5.0/
      call sprsin(a,NP,NP,0.5,NMAX,sa,ija)
      call sprstp(sa,ija,sat,ijat)
      do 12 i=1,NP
        do 11 j=1,NP
          at(i,j)=0.0
11      continue
12    continue
      do 14 i=1,NP
        at(i,i)=sat(i)
        do 13 j=ijat(i),ijat(i+1)-1
          at(i,ijat(j))=sat(j)
13      continue
14    continue
      write(*,*) 'Original matrix:'
      write(*,'(5f7.1)') ((a(i,j),j=1,NP),i=1,NP)
      write(*,*) 'Transpose:'
      write(*,'(5f7.1)') ((at(i,j),j=1,NP),i=1,NP)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsprstp.for


program dla
  use arrayfire
  implicit none

  type(array) A, B, C, X0, X1, X2
  type(array) l, u, p, r, diff
  integer :: N

  ! Set the size of the matrix
  N = 5

  ! Randomly generate a system
  A = randu(N, N)
  X0 = randu(N, 1)

  ! LU decomposition
  call lu(l, u, p, A)

  ! Construct a positive definite matrix
  C = A + transpose(A) + identity(N, N) * 100.0
  call cholesky(r, C)

  ! Solve a general system of equations
  B = matmul(A, X0)
  X1 = solve(A, B)
  call print(max(abs(X0 - X1)), "absolute error: Solving general system")

  ! Solve a positive definite system of equations
  B = matmul(C, X0)
  X2 = solve(C, B)
  call print(max(abs(X0 - X2)), "absolute error: Solving positive definite system")

  ! Invert a matrix
  r = inverse(A)
  diff = abs(identity(N, N) - matmul(r, A))
  call print(max(moddims(diff, N * N, 1)), "absolute error: Inverting a matrix")

end program dla


      PROGRAM xlinmin
C     driver for routine linmin
      INTEGER NDIM
      REAL PIO2
      PARAMETER(NDIM=3,PIO2=1.5707963)
      INTEGER i,j
      REAL fret,sr2,x,p(NDIM),xi(NDIM)
      write(*,'(/1x,a)') 'Minimum of a 3-D quadratic centered'
      write(*,'(1x,a)') 'at (1.0,1.0,1.0). Minimum is found'
      write(*,'(1x,a)') 'along a series of radials.'
      write(*,'(/1x,t10,a,t22,a,t34,a,t42,a/)') 'x','y','z','minimum'
      do 11 i=0,10
        x=PIO2*i/10.0
        sr2=sqrt(2.0)
        xi(1)=sr2*cos(x)
        xi(2)=sr2*sin(x)
        xi(3)=1.0
        p(1)=0.0
        p(2)=0.0
        p(3)=0.0
        call linmin(p,xi,NDIM,fret)
        write(*,'(1x,4f12.6)') (p(j),j=1,3),fret
11    continue
      END
      REAL FUNCTION func(x)
      INTEGER i
      REAL x(3)
      func=0.0
      do 11 i=1,3
        func=func+(x(i)-1.0)**2
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xlinmin.for


    !
    ! This program may be freely redistributed under the
    ! condition that the copyright notices (including this
    ! entire header) are not removed, and no compensation
    ! is received through use of the software.  Private,
    ! research, and institutional use is free.  You may
    ! distribute modified versions of this code UNDER THE
    ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE
    ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE
    ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE
    ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR
    ! NOTICE IS GIVEN OF THE MODIFICATIONS.  Distribution
    ! of this code as part of a commercial system is
    ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE
    ! AUTHOR.  (If you are not directly supplying this
    ! code to a customer, and you are instead telling them
    ! how they can obtain it for free, then you are not
    ! required to make any arrangement with me.)
    !
    ! Disclaimer:  Neither I nor: Columbia University, the
    ! National Aeronautics and Space Administration, nor
    ! the Massachusetts Institute of Technology warrant
    ! or certify this code in any way whatsoever.  This
    ! code is provided "as-is" to be used at your own risk.
    !
    !

    !
    ! BFUN1D.f90: poly. basis-functions for reconstruction.
    !
    ! Darren Engwirda
    ! 07-Sep-2016
    ! de2363 [at] columbia [dot] edu
    !
    !

    pure subroutine bfun1d(isel,ndof,sval,bfun)

    !
    ! ISEL  basis-function "order", -1 => integral-basis ,
    !       +0 => function-basis, +1 => 1st deriv.-basis ,
    !       +2 => 2nd deriv.-basis.
    ! NDOF  no. degrees-of-freedom in basis.
    ! SVAL  local coord. at which to evaluate basis-func.,
    !       such that -1.0 <= SVAL <= +1.0 .
    ! BFUN  basis-vector evaluated at SVAL .
    !

        implicit none

    !------------------------------------------- arguments !
        integer, intent( in) :: isel,ndof
        real*8 , intent( in) :: sval
        real*8 , intent(out) :: bfun(:)

        select case (isel)
        case (-1)
    !------------------------------------ -1th-order basis !
            select case (ndof)
            case (+1)
                bfun(1) = sval**1 / 1.d0

            case (+2)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0

            case (+3)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0
                bfun(3) = sval**3 / 3.d0

            case (+4)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0
                bfun(3) = sval**3 / 3.d0
                bfun(4) = sval**4 / 4.d0

            case (+5)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0
                bfun(3) = sval**3 / 3.d0
                bfun(4) = sval**4 / 4.d0
                bfun(5) = sval**5 / 5.d0

            case (+6)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0
                bfun(3) = sval**3 / 3.d0
                bfun(4) = sval**4 / 4.d0
                bfun(5) = sval**5 / 5.d0
                bfun(6) = sval**6 / 6.d0

            case (+7)
                bfun(1) = sval**1 / 1.d0
                bfun(2) = sval**2 / 2.d0
                bfun(3) = sval**3 / 3.d0
                bfun(4) = sval**4 / 4.d0
                bfun(5) = sval**5 / 5.d0
                bfun(6) = sval**6 / 6.d0
                bfun(7) = sval**7 / 7.d0

            end select

        case (+0)
    !------------------------------------ +0th-order basis !
            select case (ndof)
            case (+1)
                bfun(1) =           1.d0

            case (+2)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0

            case (+3)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0
                bfun(3) = sval**2 * 1.d0

            case (+4)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0
                bfun(3) = sval**2 * 1.d0
                bfun(4) = sval**3 * 1.d0

            case (+5)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0
                bfun(3) = sval**2 * 1.d0
                bfun(4) = sval**3 * 1.d0
                bfun(5) = sval**4 * 1.d0

            case (+6)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0
                bfun(3) = sval**2 * 1.d0
                bfun(4) = sval**3 * 1.d0
                bfun(5) = sval**4 * 1.d0
                bfun(6) = sval**5 * 1.d0

            case (+7)
                bfun(1) =           1.d0
                bfun(2) = sval**1 * 1.d0
                bfun(3) = sval**2 * 1.d0
                bfun(4) = sval**3 * 1.d0
                bfun(5) = sval**4 * 1.d0
                bfun(6) = sval**5 * 1.d0
                bfun(7) = sval**6 * 1.d0

            end select

        case (+1)
    !------------------------------------ +1st-order basis !
            select case (ndof)
            case (+1)
                bfun(1) =           0.d0

            case (+2)
                bfun(1) =           0.d0
                bfun(2) =           1.d0

            case (+3)
                bfun(1) =           0.d0
                bfun(2) =           1.d0
                bfun(3) = sval**1 * 2.d0

            case (+4)
                bfun(1) =           0.d0
                bfun(2) =           1.d0
                bfun(3) = sval**1 * 2.d0
                bfun(4) = sval**2 * 3.d0

            case (+5)
                bfun(1) =           0.d0
                bfun(2) =           1.d0
                bfun(3) = sval**1 * 2.d0
                bfun(4) = sval**2 * 3.d0
                bfun(5) = sval**3 * 4.d0

            case (+6)
                bfun(1) =           0.d0
                bfun(2) =           1.d0
                bfun(3) = sval**1 * 2.d0
                bfun(4) = sval**2 * 3.d0
                bfun(5) = sval**3 * 4.d0
                bfun(6) = sval**4 * 5.d0

            case (+7)
                bfun(1) =           0.d0
                bfun(2) =           1.d0
                bfun(3) = sval**1 * 2.d0
                bfun(4) = sval**2 * 3.d0
                bfun(5) = sval**3 * 4.d0
                bfun(6) = sval**4 * 5.d0
                bfun(7) = sval**5 * 6.d0

            end select

        case (+2)
    !------------------------------------ +2nd-order basis !
            select case (ndof)
            case (+1)
                bfun(1) =           0.d0

            case (+2)
                bfun(1) =           0.d0
                bfun(2) =           0.d0

            case (+3)
                bfun(1) =           0.d0
                bfun(2) =           0.d0
                bfun(3) =           2.d0

            case (+4)
                bfun(1) =           0.d0
                bfun(2) =           0.d0
                bfun(3) =           2.d0
                bfun(4) = sval**1 * 6.d0

            case (+5)
                bfun(1) =           0.d0
                bfun(2) =           0.d0
                bfun(3) =           2.d0
                bfun(4) = sval**1 * 6.d0
                bfun(5) = sval**2 *12.d0

            case (+6)
                bfun(1) =           0.d0
                bfun(2) =           0.d0
                bfun(3) =           2.d0
                bfun(4) = sval**1 * 6.d0
                bfun(5) = sval**2 *12.d0
                bfun(6) = sval**3 *20.d0

            case (+7)
                bfun(1) =           0.d0
                bfun(2) =           0.d0
                bfun(3) =           2.d0
                bfun(4) = sval**1 * 6.d0
                bfun(5) = sval**2 *12.d0
                bfun(6) = sval**3 *20.d0
                bfun(7) = sval**4 *30.d0

            end select

        end select

    end subroutine