MODULE Sparse_Gaussian

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

CONTAINS

SUBROUTINE dspslv (n, a, ia, ja, b, r, c, MAX, x, itemp, rtemp, ierr)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-07-14  Time: 20:38:15

!-----------------------------------------------------------------------
!          SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS
!-----------------------------------------------------------------------
!  DSPSLV CALLS DNSPIV WHICH USES SPARSE GAUSSIAN ELIMINATION WITH COLUMN
!  INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE ELIMINATION PHASE
!  PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN A UNIT UPPER TRIANGULAR
!  MATRIX U AND A VECTOR Y.  THE SOLUTION PHASE SOLVES U X = Y.

!  INPUT ARGUMENTS---

!  N      INTEGER NUMBER OF EQUATIONS AND UNKNOWNS

!  A      DOUBLE PRECISION ARRAY WITH ONE ENTRY PER NONZERO IN A,
!         CONTAINING THE ACTUAL NONZEROS. (SEE THE MATRIX STORAGE
!         DESCRIPTION BELOW)

!  IA     INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A
!         (SEE MATRIX STORAGE DESCRIPTION BELOW)

!  JA     INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING COLUMN
!         NUMBERS OF THE NONZEROS OF A.  (SEE MATRIX STORAGE
!         DESCRIPTION BELOW)

!  B      DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE RIGHT
!         HAND SIDE DATA

!  R      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
!         ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS)

!  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
!         COLUMNS OF A.  C IS ALSO AN OUTPUT ARGUMENT

!  MAX    INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL
!         NONZERO ENTRIES OF U WHICH MAY BE STORED

!  ITEMP  INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE

!  RTEMP  DOUBLE PRECISION ARRAY OF N + MAX ENTRIES FOR INTERNAL USE

!  OUTPUT ARGUMENTS---

!  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
!         COLUMNS OF U.  C IS ALSO AN INPUT ARGUMENT

!  X      DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE SOLUTION VECTOR

!  IERR   INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR THE ACTUAL
!         NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR SUCCESSFUL COMPLETION)

!         IERR VALUES ARE---

!         0 < IERR             SUCCESSFUL COMPLETION.  IERR=MAX(1,M)
!                              WHERE M IS THE NUMBER OF OFF-DIAGONAL
!                              NONZERO ENTRIES OF U.

!         IERR = 0             ERROR.  N IS LESS THAN OR EQUAL TO 0

!         -N <= IERR < 0       ERROR.  ROW NUMBER IABS(IERR) OF A IS IS NULL

!         -2*N <= IERR < -N    ERROR.  ROW NUMBER IABS(IERR+N) HAS A
!                              DUPLICATE ENTRY

!         -3*N <= IERR < -2*N  ERROR.  ROW NUMBER IABS(IERR+2*N)
!                              HAS A ZERO PIVOT

!         -4*N <= IERR < -3*N  ERROR.  ROW NUMBER IABS(IERR+3*N)
!                              EXCEEDS STORAGE

!  STORAGE OF SPARSE MATRICES---

!  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
!  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
!  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA CONTAINS
!  THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED IN THE ARRAY A
!  (I.E., IF THE NONZERO STORED IN A(K) IS IN COLUMN J, THEN JA(K) = J).
!  THE ARRAY IA CONTAINS POINTERS TO THE ROWS OF NONZEROS/COLUMN INDICES IN
!  THE ARRAY A/JA (I.E., A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN
!  THE ARRAY A/JA).  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF
!  NONZERO ELEMENTS IN A.
!------------------------

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: a(*)
INTEGER, INTENT(IN OUT)    :: ia(*)
INTEGER, INTENT(IN OUT)    :: ja(*)
REAL (dp), INTENT(IN OUT)  :: b(n)
INTEGER, INTENT(IN OUT)    :: r(n)
INTEGER, INTENT(IN OUT)    :: c(n)
INTEGER, INTENT(IN OUT)    :: MAX
REAL (dp), INTENT(IN OUT)  :: x(n)
INTEGER, INTENT(OUT)       :: itemp(*)
REAL (dp), INTENT(IN OUT)  :: rtemp(*)
INTEGER, INTENT(OUT)       :: ierr

INTEGER :: iu, ju, k, l, u, y, p

ierr = 0
IF (n <= 0) RETURN

!  SET INDICES TO DIVIDE TEMPORARY STORAGE FOR DNSPIV

y = 1
u = y + n
p = n + 1
iu = p + n + 1
ju = iu + n + 1

!  COMPUTE THE INVERSE PERMUTATION OF C

DO  k = 1,n
  l = c(k)
  itemp(l) = k
END DO

!  CALL DNSPIV TO PERFORM COMPUTATIONS

CALL dnspiv (n, ia, ja, a, b, MAX, r, c, itemp(1), x, rtemp(y), itemp(p),  &
             itemp(iu), itemp(ju), rtemp(u), ierr)
IF (ierr == 0) ierr = 1
RETURN
END SUBROUTINE dspslv

SUBROUTINE dnspiv(n, ia, ja, a, b, MAX, r, c, ic, x, y, p, iu, ju, u, ierr)

!  DNSPIV USES SPARSE GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO SOLVE
!  THE LINEAR SYSTEM A X = B.  THE ELIMINATION PHASE PERFORMS ROW OPERATIONS
!  ON A AND B TO OBTAIN A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.
!  THE SOLUTION PHASE SOLVES U X = Y.

!  SEE DSPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS
!  OTHER THAN THOSE DESCRIBED BELOW

!  IC  INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
!      (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT ARGUMENT.

!  INPUT ARGUMENTS (USED INTERNALLY ONLY)---

!  Y   DOUBLE PRECISION ARRAY OF N ENTRIES USED TO COMPUTE THE UPDATED
!      RIGHT HAND SIDE

!  P   INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST.
!      P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING P(K) IS IN P(P(K)).
!      THUS, P(N+1) IS THE FIRST DATA ITEM, P(P(N+1)) IS THE SECOND, ETC.
!      A POINTER OF N+1 MARKS THE END OF THE LIST

!  IU  INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U
!      (SEE MATRIX STORAGE DESCRIPTION BELOW)

!  JU  INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF THE NONZEROS IN
!      THE STRICT UPPER TRIANGLE OF U.  (SEE MATRIX STORAGE DESCRIPTION BELOW)

!  U   DOUBLE PRECISION ARRAY OF MAX ENTRIES USED FOR THE ACTUAL NONZEROS IN
!      THE STRICT UPPER TRIANGLE OF U. (SEE MATRIX STORAGE DESCRIPTION BELOW)

!  STORAGE OF SPARSE MATRICES---

!  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
!  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
!  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA CONTAINS
!  THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED IN THE ARRAY A
!  (I.E., IF THE NONZERO STORED IN A(K) IS IN COLUMN J, THEN JA(K) = J).
!  THE ARRAY IA CONTAINS POINTERS TO THE ROWS OF NONZEROS/COLUMN INDICES IN
!  THE ARRAY A/JA (I.E., A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN
!  THE ARRAY A/JA). IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF
!  NONZEROS IN A.  IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT
!  UPPER TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J

INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: ia(*)
INTEGER, INTENT(IN)        :: ja(*)
REAL (dp), INTENT(IN)      :: a(*)
REAL (dp), INTENT(IN)      :: b(n)
INTEGER, INTENT(IN)        :: MAX
INTEGER, INTENT(IN)        :: r(n)
INTEGER, INTENT(IN OUT)    :: c(n)
INTEGER, INTENT(IN OUT)    :: ic(n)
REAL (dp), INTENT(OUT)     :: x(n)
REAL (dp), INTENT(IN OUT)  :: y(n)
INTEGER, INTENT(OUT)       :: p(*)
INTEGER, INTENT(OUT)       :: iu(*)
INTEGER, INTENT(IN OUT)    :: ju(MAX)
REAL (dp), INTENT(IN OUT)  :: u(MAX)
INTEGER, INTENT(OUT)       :: ierr

REAL (dp)  :: dk, lki, xpv, xpvmax, yk

INTEGER    :: ck, i, j, jaj, jmin, jmax, juj, juptr, k, maxc, maxcl, nzcnt,  &
              pk, ppk, pv, v, vi, vj, vk

!  INITIALIZE WORK STORAGE AND POINTERS TO JU

x(1:n) = 0.d0
iu(1) = 1
juptr = 0

!  PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW
!  VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U

DO  k = 1, n

!  INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW
!  THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U.

  p(n+1) = n + 1
  vk = r(k)

!  SET UP ADJACENCY LIST FOR VK, ORDERED IN CURRENT COLUMN ORDER OF U.
!  THE LOOP INDEX GOES DOWNWARD TO EXPLOIT ANY COLUMNS FROM A
!  IN CORRECT RELATIVE ORDER

  jmin = ia(vk)
  jmax = ia(vk+1) - 1
  IF (jmin > jmax) GO TO 170
  j = jmax
  20   jaj = ja(j)
  vj = ic(jaj)

!  STORE A(K,J) IN WORK VECTOR

  x(vj) = a(j)
!  THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK
  ppk = n + 1
  30   pk = ppk
  ppk = p(pk)
  IF (ppk-vj < 0.0) THEN
    GO TO    30
  ELSE IF (ppk-vj == 0.0) THEN
    GO TO   180
  END IF
  p(vj) = ppk
  p(pk) = vj
  j = j - 1
  IF (j >= jmin) GO TO 20

!  THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U

  vi = n + 1
  yk = b(vk)
  50   vi = p(vi)
  IF (vi < k) THEN

!  VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE
!  ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK

    lki = -x(vi)
    x(vi) = 0.d0

!  ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION

    yk = yk + lki * y(vi)
    ppk = vi
    jmin = iu(vi)
    jmax = iu(vi+1) - 1
    IF (jmin > jmax) GO TO 50
    DO  j = jmin, jmax
      juj = ju(j)
      vj = ic(juj)

!  IF VJ IS ALREADY IN THE ADJACENCY OF VK, SKIP THE INSERTION

      IF (x(vj) == 0.d0) THEN

!  INSERT VJ IN ADJACENCY LIST OF VK.
!  RESET PPK TO VI IF WE HAVE PASSED THE CORRECT INSERTION SPOT.
!  (THIS HAPPENS WHEN THE ADJACENCY OF
!  VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.)

        IF (vj-ppk < 0.0) THEN
          GO TO    60
        ELSE IF (vj-ppk == 0.0) THEN
          GO TO    90
        ELSE
          GO TO    70
        END IF
        60  ppk = vi
        70  pk = ppk
        ppk = p(pk)
        IF (ppk-vj < 0.0) THEN
          GO TO    70
        ELSE IF (ppk-vj == 0.0) THEN
          GO TO    90
        END IF
        p(vj) = ppk
        p(pk) = vj
        ppk = vj
      END IF

!  COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO
!  COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO
!  (U*(K,J) = U(K,J)*D(K,K))

      90  x(vj) = x(vj) + lki * u(j)
    END DO
    GO TO 50
  END IF

!  PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH THE DIAGONAL ENTRY.

!  FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS

  IF (vi > n) GO TO 190
  xpvmax = ABS(x(vi))
  maxc = vi
  nzcnt = 0
  pv = vi
  110   v = pv
  pv = p(pv)
  IF (pv <= n) THEN
    nzcnt = nzcnt + 1
    xpv = ABS(x(pv))
    IF (xpv <= xpvmax) GO TO 110
    xpvmax = xpv
    maxc = pv
    maxcl = v
    GO TO 110
  END IF
  IF (xpvmax == 0.d0) GO TO 190

!  IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL
!  WHICH MUST BE DELETED.  OTHERWISE, DELETE THE
!  ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY

  IF (vi /= k) THEN
    IF (vi /= maxc) THEN
      p(maxcl) = p(maxc)
      GO TO 120
    END IF
  END IF
  vi = p(vi)

!  COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE.

  120 dk = 1.d0 / x(maxc)
  x(maxc) = x(k)
  i = c(k)
  c(k) = c(maxc)
  c(maxc) = i
  ck = c(k)
  ic(ck) = k
  ic(i) = maxc
  x(k) = 0.d0

!  UPDATE RIGHT HAND SIDE.

  y(k) = yk * dk

!  COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW

  iu(k+1) = iu(k) + nzcnt
  IF (iu(k+1) > MAX+1) GO TO 200

!  MOVE COLUMN INDICES FROM LINKED LIST TO JU.
!  COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL
!  COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J

  IF (vi <= n) THEN
    j = vi
    130  juptr = juptr + 1
    ju(juptr) = c(j)
    u(juptr) = x(j) * dk
    x(j) = 0.d0
    j = p(j)
    IF (j <= n) GO TO 130
  END IF
END DO

!  BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A

k = n
DO  i = 1, n
  yk = y(k)
  jmin = iu(k)
  jmax = iu(k+1) - 1
  IF (jmin <= jmax) THEN
    DO  j = jmin, jmax
      juj = ju(j)
      juj = ic(juj)
      yk = yk - u(j) * y(juj)
    END DO
  END IF
  y(k) = yk
  ck = c(k)
  x(ck) = yk
  k = k - 1
END DO

!  RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U

ierr = iu(n+1) - iu(1)
RETURN

!  ERROR RETURNS

!  ROW K OF A IS NULL

170 ierr = -k
RETURN

!  ROW K OF A HAS A DUPLICATE ENTRY

180 ierr = -(n+k)
RETURN

!  ZERO PIVOT IN ROW K

190 ierr = -(2*n+k)
RETURN

!  STORAGE FOR U EXCEEDED ON ROW K

200 ierr = -(3*n+k)
RETURN
END SUBROUTINE dnspiv

END MODULE Sparse_Gaussian


      SUBROUTINE savgol(c,np,nl,nr,ld,m)
      INTEGER ld,m,nl,np,nr,MMAX
      REAL c(np)
      PARAMETER (MMAX=6)
CU    USES lubksb,ludcmp
      INTEGER imj,ipj,j,k,kk,mm,indx(MMAX+1)
      REAL d,fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1)
      if(np.lt.nl+nr+
     *1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX.or.nl+nr.lt.m)
     *pause 'bad args in savgol'
      do 14 ipj=0,2*m
        sum=0.
        if(ipj.eq.0)sum=1.
        do 11 k=1,nr
          sum=sum+float(k)**ipj
11      continue
        do 12 k=1,nl
          sum=sum+float(-k)**ipj
12      continue
        mm=min(ipj,2*m-ipj)
        do 13 imj=-mm,mm,2
          a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum
13      continue
14    continue
      call ludcmp(a,m+1,MMAX+1,indx,d)
      do 15 j=1,m+1
        b(j)=0.
15    continue
      b(ld+1)=1.
      call lubksb(a,m+1,MMAX+1,indx,b)
      do 16 kk=1,np
        c(kk)=0.
16    continue
      do 18 k=-nl,nr
        sum=b(1)
        fac=1.
        do 17 mm=1,m
          fac=fac*k
          sum=sum+b(mm+1)*fac
17      continue
        kk=mod(np-k,np)+1
        c(kk)=sum
18    continue
      return
      END

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


C
C	$Id: csgradg.f,v 1.5 2008-07-27 03:10:06 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSGRADG (N,X,Y,Z,F,LIST,LPTR,LEND,IFLGS,
     .                  SIGMA, NIT,DGMAX,GRAD, IER)
      INTEGER N, LIST(*), LPTR(*), LEND(N), IFLGS, NIT, IER
      DOUBLE PRECISION X(N), Y(N), Z(N), F(N), SIGMA(*),
     .                 DGMAX, GRAD(3,N)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/24/96
C
C   Given a triangulation of N nodes on the unit sphere with
C data values F at the nodes and tension factors SIGMA asso-
C ciated with the arcs, this routine uses a global method
C to compute estimated gradients at the nodes.  The method
C consists of minimizing a quadratic functional Q(G) over
C the N-vector G of gradients, where Q approximates the
C linearized curvature of the restriction to arcs of the
C interpolatory function F defined by Function CSFVAL.  The
C restriction of F to an arc of the triangulation is the
C Hermite interpolatory tension spline defined by the data
C values and tangential gradient components at the endpoints
C of the arc.  Letting D1F(A) and D2F(A) denote first and
C second derivatives of F with respect to a parameter A var-
C ying along a triangulation arc, Q is the sum of integrals
C over the arcs of D2F(A)**2 + ((SIGMA/L)*(D1F(A)-S))**2,
C where L denotes arc-length, SIGMA is the appropriate ten-
C sion factor, and S is the slope of the linear function of
C A which interpolates the values of F at the endpoints of
C the arc.
C
C   Since the gradient at node K lies in the plane tangent
C to the sphere surface at K, it is effectively defined by
C only two components -- its X and Y components in the coor-
C dinate system obtained by rotating K to the north pole.
C Thus, the minimization problem corresponds to an order-2N
C symmetric positive-definite sparse linear system which is
C solved by a block Gauss-Seidel method with 2 by 2 blocks.
C
C   An alternative method, Subroutine CSGRADL, computes a
C local approximation to the gradient at a single node and,
C although less efficient when all gradients are needed, was
C found to be generally more accurate (in the case of uni-
C form zero tension) when the nodal distribution is very
C dense, varies greatly, or does not cover the sphere.
C CSGRADG, on the other hand, was found to be slightly more
C accurate on a uniform distribution of 514 nodes.
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y,Z = Arrays of length N containing Cartesian
C               coordinates of the nodes.  X(I)**2 + Y(I)**2
C               + Z(I)**2 = 1 for I = 1,...,N.
C
C       F = Array of length N containing data values at the
C           nodes.  F(I) is associated with (X(I),Y(I),Z(I))
C           for I = 1,...,N.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to STRIPACK
C                        Subroutine CSTRMESH.
C
C       IFLGS = Tension factor option:
C               IFLGS .LE. 0 if a single uniform tension
C                            factor is to be used.
C               IFLGS .GE. 1 if variable tension is desired.
C
C       SIGMA = Uniform tension factor (IFLGS .LE. 0), or
C               array containing tension factors associated
C               with arcs in one-to-one correspondence with
C               LIST entries (IFLGS .GE. 1).  Refer to Sub-
C               programs CSGETSIG, CSSIG0, CSSIG1, and CSSIG2.
C
C The above parameters are not altered by this routine.
C
C       NIT = Maximum number of Gauss-Seidel iterations to
C             be applied.  This maximum will likely be a-
C             chieved if DGMAX is smaller than the machine
C             precision.  NIT .GE. 0.
C
C       DGMAX = Nonnegative convergence criterion.  The
C               method is terminated when the maximum change
C               in a gradient between iterations is at most
C               DGMAX.  The change in a gradient is taken to
C               be the Euclidean norm of the difference (in
C               the rotated coordinate system) relative to 1
C               plus the norm of the old gradient value.
C
C       GRAD = 3 by N array whose columns contain initial
C              solution estimates (zero vectors are suffici-
C              ent).  GRAD(I,J) contains component I of the
C              gradient at node J for I = 1,2,3 (X,Y,Z) and
C              J = 1,...,N.  GRAD( ,J) must be orthogonal to
C              node J -- GRAD(1,J)*X(J) + GRAD(2,J)*Y(J) +
C              GRAD(3,J)*Z(J) = 0.
C
C On output:
C
C       NIT = Number of Gauss-Seidel iterations employed.
C
C       DGMAX = Maximum change in a gradient at the last
C               iteration.
C
C       GRAD = Estimated gradients.  See the description
C              under input parameters.  GRAD is not changed
C              if IER = -1.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered and the
C                     convergence criterion was achieved.
C             IER = 1 if no errors were encountered but con-
C                     vergence was not achieved within NIT
C                     iterations.
C             IER = -1 if N or DGMAX is outside its valid
C                      range or NIT .LT. 0 on input.
C             IER = -2 if all nodes are collinear or the
C                      triangulation is invalid.
C             IER = -3 if duplicate nodes were encountered.
C
C SSRFPACK modules required by CSGRADG:  CSAPLYRT, CSCONSTR,
C                                        CSGRCOEF, CSSNHCSH
C
C Intrinsic functions called by CSGRADG:  ATAN, MAX, SQRT
C
C***********************************************************
C
      INTEGER IFL, ITER, J, K, LPJ, LPL, MAXIT, NN
      DOUBLE PRECISION ALFA, A11, A12, A22, CX, CY, D, DEN,
     .                 DET, DGK(3), DGMX, DG1, DG2, FK, G1,
     .                 G2, G3, R1, R2, SD, SIG, SINAL, SX,
     .                 SY, T, TOL, XK, YK, ZK, XJ, YJ, ZJ,
     .                 XS, YS
C
C Local parameters:
C
C ALFA =        Arc-length between nodes K and J
C A11,A12,A22 = Matrix components of the 2 by 2 block A*DG
C                 = R where A is symmetric, (DG1,DG2,0) is
C                 the change in the gradient at K, and R is
C                 the residual
C CX,CY =       Components of a rotation mapping K to the
C                 north pole (0,0,1)
C D =           Function of SIG computed by CSGRCOEF -- factor
C                 in the order-2 system
C DEN =         ALFA*SINAL**2 -- factor in the 2 by 2 system
C DET =         Determinant of the order-2 matrix
C DGK =         Change in GRAD( ,K) from the previous esti-
C                 mate in the original coordinate system
C DGMX =        Maximum change in a gradient between itera-
C                 tions
C DG1,DG2 =     Solution of the 2 by 2 system -- first 2
C                 components of DGK in the rotated coordi-
C                 nate system
C FK =          Data value F(K)
C G1,G2,G3 =    Components of GRAD( ,K)
C IFL =         Local copy of IFLGS
C ITER =        Number of iterations used
C J =           Neighbor of K
C K =           DO-loop and node index
C LPJ =         LIST pointer of node J as a neighbor of K
C LPL =         Pointer to the last neighbor of K
C MAXIT =       Input value of NIT
C NN =          Local copy of N
C R1,R2 =       Components of the residual -- derivatives of
C                 Q with respect to the components of the
C                 gradient at node K
C SD =          Function of SIG computed by CSGRCOEF -- factor
C                 in the order-2 system
C SIG =         Tension factor associated with ARC K-J
C SINAL =       SIN(ALFA) -- magnitude of the vector cross
C                 product between nodes K and J
C SX,SY =       Components of a rotation mapping K to the
C                 north pole (0,0,1)
C T =           Temporary storage for factors in the system
C                 components
C TOL =         Local copy of DGMAX
C XK,YK,ZK =    Coordinates of node K -- X(K), Y(K), Z(K)
C XJ,YJ,ZJ =    Coordinates of node J in the rotated coor-
C                 dinate system
C XS,YS =       XJ**2, YJ**2
C
      NN = N
      IFL = IFLGS
      MAXIT = NIT
      TOL = DGMAX
C
C Test for errors in input, and initialize iteration count,
C   tension factor, and output value of DGMAX.
C
      IF (NN .LT. 3  .OR.  MAXIT .LT. 0  .OR.  TOL .LT. 0.)
     .   GO TO 11
      ITER = 0
      SIG = SIGMA(1)
      DGMX = 0.
C
C Top of iteration loop.
C
    1 IF (ITER .EQ. MAXIT) GO TO 4
      DGMX = 0.
C
C Loop on nodes.
C
      DO 3 K = 1,NN
        XK = X(K)
        YK = Y(K)
        ZK = Z(K)
        FK = F(K)
        G1 = GRAD(1,K)
        G2 = GRAD(2,K)
        G3 = GRAD(3,K)
C
C   Construct the rotation mapping node K to the north pole.
C
        CALL CSCONSTR (XK,YK,ZK, CX,SX,CY,SY)
C
C   Initialize components of the 2 by 2 system for the
C     change (DG1,DG2,0) in the K-th solution components
C     (symmetric matrix in A and residual in R).
C
        A11 = 0.
        A12 = 0.
        A22 = 0.
        R1 = 0.
        R2 = 0.
C
C   Loop on neighbors J of node K.
C
        LPL = LEND(K)
        LPJ = LPL
    2   LPJ = LPTR(LPJ)
          J = ABS(LIST(LPJ))
C
C   Compute the coordinates of J in the rotated system.
C
          T = SX*Y(J) + CX*Z(J)
          YJ = CX*Y(J) - SX*Z(J)
          ZJ = SY*X(J) + CY*T
          XJ = CY*X(J) - SY*T
C
C   Compute arc-length ALFA between J and K, SINAL =
C     SIN(ALFA), and DEN = ALFA*SIN(ALFA)**2.
C
          ALFA = 2.D0*ATAN(SQRT((1.D0-ZJ)/(1.D0+ZJ)))
          XS = XJ*XJ
          YS = YJ*YJ
          SINAL = SQRT(XS+YS)
          DEN = ALFA*(XS+YS)
C
C   Test for coincident nodes and compute functions of SIG:
C     D = SIG*(SIG*COSHM-SINHM)/E and SD = SIG*SINHM/E for
C     E = SIG*SINH-2*COSHM.
C
          IF (DEN .EQ. 0.) GO TO 13
          IF (IFL .GE. 1) SIG = SIGMA(LPJ)
          CALL CSGRCOEF (SIG, D,SD)
C
C   Update the system components for node J.
C
          T = D/DEN
          A11 = A11 + T*XS
          A12 = A12 + T*XJ*YJ
          A22 = A22 + T*YS
          T = (D+SD)*(FK-F(J))/(ALFA*ALFA*SINAL) +
     .        ( D*(G1*X(J) + G2*Y(J) + G3*Z(J)) -
     .          SD*(GRAD(1,J)*XK + GRAD(2,J)*YK +
     .                 GRAD(3,J)*ZK) )/DEN
          R1 = R1 - T*XJ
          R2 = R2 - T*YJ
C
C   Bottom of loop on neighbors.
C
          IF (LPJ .NE. LPL) GO TO 2
C
C   Solve the 2 by 2 system and update DGMAX.
C
        DET = A11*A22 - A12*A12
        IF (DET .EQ. 0.  .OR.  A11 .EQ. 0.) GO TO 12
        DG2 = (A11*R2 - A12*R1)/DET
        DG1 = (R1 - A12*DG2)/A11
        DGMX = MAX(DGMX,SQRT(DG1*DG1+DG2*DG2)/
     .             (1.+SQRT(G1*G1+G2*G2+G3*G3)))
C
C   Rotate (DG1,DG2,0) back to the original coordinate
C     system and update GRAD( ,K).
C
        CALL CSAPLYRT (DG1,DG2,CX,SX,CY,SY, DGK)
        GRAD(1,K) = G1 + DGK(1)
        GRAD(2,K) = G2 + DGK(2)
        GRAD(3,K) = G3 + DGK(3)
    3   CONTINUE
C
C   Increment ITER and test for convergence.
C
      ITER = ITER + 1
      IF (DGMX .GT. TOL) GO TO 1
C
C The method converged.
C
      NIT = ITER
      DGMAX = DGMX
      IER = 0
      RETURN
C
C The method failed to converge within NIT iterations.
C
    4 DGMAX = DGMX
      IER = 1
      RETURN
C
C Invalid input parameter.
C
   11 NIT = 0
      DGMAX = 0.
      IER = -1
      RETURN
C
C Node K and its neighbors are collinear.
C
   12 NIT = 0
      DGMAX = DGMX
      IER = -2
      RETURN
C
C Nodes K and J coincide.
C
   13 NIT = 0
      DGMAX = DGMX
      IER = -3
      RETURN
      END


C$Procedure      ELLTOF ( Elliptic time of flight )

      SUBROUTINE ELLTOF ( MA, ECC, E )

C$ Abstract
C
C     Solve the time of flight equation MA = E - e sin(E) for the
C     elliptic eccentric anomaly E, given mean anomaly the MA and
C     the eccentricity ECC.
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
C$ Declarations

      DOUBLE PRECISION      MA
      DOUBLE PRECISION      ECC
      DOUBLE PRECISION      E

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MA         I   Mean anomaly at epoch.
C     ECC        I   Eccentricity.
C     E          O   Elliptic eccentric anomaly.
C
C$ Detailed_Input
C
C     MA          is the elliptic mean anomaly of an orbiting body at
C                 some epoch t,
C
C                                      3 1/2
C                       MA = (t-T)(mu/a )
C
C                 where T is the time of periapsis passage, a is
C                 the semi-major axis of the orbit, and mu is the
C                 gravitational parameter of the primary body.
C
C     ECC         is the eccentricity of the orbit.
C
C$ Detailed_Output
C
C     E           is the corresponding eccentric anomaly. This is the
C                 solution to the time of flight equation
C
C                       MA = E - e sin(E)
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     1) If the eccentricity (ECC) is outside the range [0,1),
C        the error 'SPICE(WRONGCONIC)' is signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Iterate to solve
C
C           f(E,MA,e) = E - e sin(E) - MA = 0
C
C$ Examples
C
C     ELLTOF, HYPTOF, and PARTOF are used by CONICS.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971.
C
C     [2] Ed Ng, "A General Algorithm for the Solution of Kepler's
C         Equation for Elliptic Orbits", Cel. Mech. 20, 243, 1979.
C
C$ Author_and_Institution
C
C     K.R. Gehringer  (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     elliptic time of flight
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 8-JAN-1989 (IMU)
C
C        The routine now verifies that the eccentricity is in the
C        proper range---[0,1)---before proceeding.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      DOUBLE PRECISION      DCBRT
      DOUBLE PRECISION      HALFPI
      EXTERNAL              PI
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      TWOPI

C
C     Local parameters
C
      DOUBLE PRECISION      TOL
      PARAMETER           ( TOL = 1.D-15 )

C
C     Local variables
C
      DOUBLE PRECISION      M
      DOUBLE PRECISION      MPRIME
      INTEGER               N

      DOUBLE PRECISION      M0
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      Q
      DOUBLE PRECISION      R
      DOUBLE PRECISION      QR
      DOUBLE PRECISION      Y

      DOUBLE PRECISION      FN
      DOUBLE PRECISION      DERIV
      DOUBLE PRECISION      DERIV2
      DOUBLE PRECISION      CHANGE

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

      IF ( ECC .LT. 0.D0  .OR.  ECC .GE. 1.D0 ) THEN
         CALL SIGERR ( 'SPICE(WRONGCONIC)' )
         CALL CHKOUT ( 'ELLTOF'            )
         RETURN
      END IF

C
C     For reasons of numerical stability, we would like to restrict
C     our solution to the interval [0,pi]. Because E, M, and sin E
C     are always positive or negative together, we can pretend that M
C     is positive and adjust the sign of the result. And for M, E > pi,
C     we can define
C
C           M = 2n pi + M'     and    E = 2n pi + E'
C
C     where M' and E' are in the interval [-pi,pi]. Solving for E'
C     gives us E.
C
C     So, we begin by reducing the input mean anomaly to [0,pi].
C
      M = ABS ( MA )

      IF ( M .GT. PI() ) THEN
         N      = INT ( (M-PI()) / TWOPI() ) + 1
         MPRIME = M - N * TWOPI()
      ELSE
         N      = 0
         MPRIME = M
      END IF

      M = ABS ( MPRIME )

C
C     The convergence of the iterative scheme below depends on a good
C     initial estimate for E.
C
C     For small eccentricity, the initial estimate E = M is sufficient.
C     However, as the eccentricity increases, so does the number of
C     iterations required for convergence. For sufficiently large
C     eccentricity, this estimate leads to divergence.
C
C     Ng [2] notes that the function y(M,e)
C
C           E - M
C          -------  =  sin(e y + M)
C             e
C
C     increases and decreases monotonically when M is in the ranges
C     [0,M0] and [m0,pi], respectively.
C
C     When M0 < M < pi, where M0 = (pi/2) - e, the cubic
C             -   -
C
C                              pi - M  2        pi - M    pi - M
C           B(M,e) = 1 - (1 -  -------)  (1 + 2 ------- - -------)
C                              pi - M0          pi - M0    1 + e
C
C     provides a good initial estimate of y for all values of e.
C
C
      M0 = HALFPI() - ECC

      IF ( M .GE. M0 ) THEN

         A = PI() - M
         B = PI() - M0

         Y = 1.D0 - (1.D0 - A/B)**2 * (1.D0 + 2.D0*A/B - A/(1.D0+ECC))
         E = ECC * SIN(ECC*Y + M) + M

C
C     The situation is a little more troublesome, however, when M < M0.
C     For small eccentricity, the cubic
C
C                                  2
C           A(M,e) = 1 - (1 - M/M0)  (1 + 2M/M0 - M/(1-e) )
C
C     gives a reasonable first estimate of y. However, as e -> 1,
C     successive approximations of the form
C
C                             k           k
C           C (M,e) = 1 - (-1)  (1 - M/M0)
C            k
C
C     are used, where k = 4 for e > 0.7, and k = 8 for e > 0.85.
C
C     For high eccentricity (e > 0.96) and low mean anomaly (M < 0.05),
C     these successive approximations eventually fail. Fortunately, in
C     just these cases, the cubic
C
C                           3    2  1/3           3    2  1/3
C           D(M,e) = [r + (q  + r )]     + [r - (q  + r )]
C
C     where
C
C           r = 3M/e,   q = (2/e)(1 - e)
C
C     provides a reasonable estimate of E directly.
C
C
      ELSE IF ( ECC .LE. 0.7D0 ) THEN

         Y = 1.D0 - (1.D0 - M/M0)**2 * (1.D0 + 2.D0*M/M0 - M/(1.D0-ECC))
         E = ECC * SIN(ECC*Y + M) + M

      ELSE IF ( ECC .LE. 0.85D0 ) THEN

         Y = 1.D0 - (1.D0 - M/M0)**4
         E = ECC * SIN(ECC*Y + M) + M

      ELSE IF ( ECC .LE. 0.96D0 .OR. M .GT. 0.05D0 ) THEN

         Y = 1.D0 - (1.D0 - M/M0)**8
         E = ECC * SIN(ECC*Y + M) + M

      ELSE

         Q  = (2.D0/ECC) * (1.D0 - ECC)
         R  = 3.D0 * (M/ECC)
         QR = SQRT ( Q**3 + R**2 )

         E  = DCBRT ( R + QR ) + DCBRT ( R - QR )

      END IF

C
C     Use the Newton second-order method,
C
C                                           2
C          E    = E  - (f/f')*(1 + f*f''/2f' )
C           i+1    i
C
C     where
C
C          f   = E - e sin(E) - M
C          f'  = 1 - e cos(E)
C          f'' =     e sin(E)
C
      CHANGE = 1.D0

      DO WHILE ( ABS ( CHANGE ) .GT. TOL )

         FN     = E    - ECC * SIN(E) - M
         DERIV  = 1.D0 - ECC * COS(E)
         DERIV2 =        ECC * SIN(E)

         CHANGE = (FN/DERIV) * ( 1.D0 + (FN*DERIV2) / (2.D0*DERIV**2) )
         E      = E - CHANGE

      END DO

C
C     "Unwrap" E' into the actual value of E.
C
      IF ( MPRIME .LT. 0 ) THEN
         E = -E
      END IF

      IF ( N .GT. 0 ) THEN
         E = E + N * TWOPI()
      END IF

      IF ( MA .LT. 0 ) THEN
         E = -E
      END IF

      CALL CHKOUT ( 'ELLTOF' )
      RETURN
      END


*
* Program factable - compute the factorial table
*
* Written by - Charles Severance 12Mar92
*
      INTEGER I,N,FAC
*
* Print heading
*
      PRINT 100
      PRINT 200
*
*  Loop thruogh the numbers 1-10 and print out the factorials
*
      DO N=1,10
        FAC = 1
        DO I=2,N
          FAC = FAC * I
        ENDDO
        PRINT 300,N,FAC
      ENDDO
*
100   FORMAT('      NUMBER      FACTORIAL')
200   FORMAT('      ------      ---------')
300   FORMAT(6X,I6,6X,I10)
      END


      SUBROUTINE linbcg(n,b,x,itol,tol,itmax,iter,err)
      INTEGER iter,itmax,itol,n,NMAX
      DOUBLE PRECISION err,tol,b(*),x(*),EPS
      PARAMETER (NMAX=1024,EPS=1.d-14)
CU    USES atimes,asolve,snrm
      INTEGER j
      DOUBLE PRECISION ak,akden,bk,bkden,bknum,bnrm,dxnrm,xnrm,zm1nrm,
     *znrm,p(NMAX),pp(NMAX),r(NMAX),rr(NMAX),z(NMAX),zz(NMAX),snrm
      iter=0
      call atimes(n,x,r,0)
      do 11 j=1,n
        r(j)=b(j)-r(j)
        rr(j)=r(j)
11    continue
C     call atimes(n,r,rr,0)
      if(itol.eq.1) then
        bnrm=snrm(n,b,itol)
        call asolve(n,r,z,0)
      else if (itol.eq.2) then
        call asolve(n,b,z,0)
        bnrm=snrm(n,z,itol)
        call asolve(n,r,z,0)
      else if (itol.eq.3.or.itol.eq.4) then
        call asolve(n,b,z,0)
        bnrm=snrm(n,z,itol)
        call asolve(n,r,z,0)
        znrm=snrm(n,z,itol)
      else
        pause 'illegal itol in linbcg'
      endif
100   if (iter.le.itmax) then
        iter=iter+1
        call asolve(n,rr,zz,1)
        bknum=0.d0
        do 12 j=1,n
          bknum=bknum+z(j)*rr(j)
12      continue
        if(iter.eq.1) then
          do 13 j=1,n
            p(j)=z(j)
            pp(j)=zz(j)
13        continue
        else
          bk=bknum/bkden
          do 14 j=1,n
            p(j)=bk*p(j)+z(j)
            pp(j)=bk*pp(j)+zz(j)
14        continue
        endif
        bkden=bknum
        call atimes(n,p,z,0)
        akden=0.d0
        do 15 j=1,n
          akden=akden+z(j)*pp(j)
15      continue
        ak=bknum/akden
        call atimes(n,pp,zz,1)
        do 16 j=1,n
          x(j)=x(j)+ak*p(j)
          r(j)=r(j)-ak*z(j)
          rr(j)=rr(j)-ak*zz(j)
16      continue
        call asolve(n,r,z,0)
        if(itol.eq.1)then
          err=snrm(n,r,itol)/bnrm
        else if(itol.eq.2)then
          err=snrm(n,z,itol)/bnrm
        else if(itol.eq.3.or.itol.eq.4)then
          zm1nrm=znrm
          znrm=snrm(n,z,itol)
          if(abs(zm1nrm-znrm).gt.EPS*znrm) then
            dxnrm=abs(ak)*snrm(n,p,itol)
            err=znrm/abs(zm1nrm-znrm)*dxnrm
          else
            err=znrm/bnrm
            goto 100
          endif
          xnrm=snrm(n,x,itol)
          if(err.le.0.5d0*xnrm) then
            err=err/xnrm
          else
            err=znrm/bnrm
            goto 100
          endif
        endif
        write (*,*) ' iter=',iter,' err=',err
      if(err.gt.tol) goto 100
      endif
      return
      END

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


c------------------------------------------------------------------
c   Calculates all first/second x/t derivative of metric functions
c------------------------------------------------------------------
          subroutine calcall (
     &              Gxx_a  , Gxx  , Gxx_r,
     &              Gyy_a  , Gyy  , Gyy_r,
     &              Gzz_a  , Gzz  , Gzz_r,
     &              alpha_a, alpha, alpha_r,
     &              beta_a , beta , beta_r,
     &              Gxx_x, Gxx_t, Gxx_xt, Gxx_tt, Gxx_xx,
     &              Gyy_x, Gyy_t, Gyy_xt, Gyy_tt, Gyy_xx,
     &              Gzz_x, Gzz_t, Gzz_xt, Gzz_tt, Gzz_xx,
     &              alpha_x, alpha_t, alpha_xt, alpha_tt, alpha_xx,
     &              beta_x , beta_t , beta_xt , beta_tt , beta_xx,
     &              n, dx, dt
     &                     )
          implicit none
          integer n
          real*8 dx, dt
          real*8 Gxx_a(1:n), Gxx(1:n), Gxx_r(1:n)
          real*8 Gyy_a(1:n), Gyy(1:n), Gyy_r(1:n)
          real*8 Gzz_a(1:n), Gzz(1:n), Gzz_r(1:n)

          real*8 alpha_a(1:n), alpha(1:n), alpha_r(1:n)

          real*8 beta_a(1:n), beta(1:n), beta_r(1:n)

          real*8 Gxx_x (1:n), Gyy_x (1:n), Gzz_x (1:n)
          real*8 Gxx_t (1:n), Gyy_t (1:n), Gzz_t (1:n)
          real*8 Gxx_xt(1:n), Gyy_xt(1:n), Gzz_xt(1:n)
          real*8 Gxx_tt(1:n), Gyy_tt(1:n), Gzz_tt(1:n)
          real*8 Gxx_xx(1:n), Gyy_xx(1:n), Gzz_xx(1:n)

          real*8 alpha_x (1:n), beta_x (1:n)
          real*8 alpha_t (1:n), beta_t (1:n)
          real*8 alpha_xx(1:n), beta_xx(1:n)
          real*8 alpha_xt(1:n), beta_xt(1:n)
          real*8 alpha_tt(1:n), beta_tt(1:n)

          call calcallDiv(Gxx_a,   Gxx ,    Gxx_r ,
     &                        dx ,   dt,    n   ,
     &                        Gxx_x,   Gxx_t,   Gxx_xx, Gxx_tt , Gxx_xt)

          call calcallDiv(Gyy_a,   Gyy ,    Gyy_r ,
     &                        dx ,   dt,    n   ,
     &                        Gyy_x,   Gyy_t,   Gyy_xx, Gyy_tt , Gyy_xt)

          call calcallDiv(Gzz_a,   Gzz ,    Gzz_r ,
     &                        dx ,   dt,    n   ,
     &                        Gzz_x,   Gzz_t,   Gzz_xx, Gzz_tt , Gzz_xt)

          call calcallDiv(alpha_a,   alpha ,    alpha_r ,
     &                        dx ,   dt,    n   ,
     &                        alpha_x,   alpha_t,   alpha_xx, alpha_tt
     &                          , alpha_xt)
          call calcallDiv(beta_a,   beta ,    beta_r ,
     &                        dx ,   dt,    n   ,
     &                        beta_x,   beta_t,   beta_xx, beta_tt
     &                          , beta_xt)

          return
          end

c-----------------------------------------------------------------
c calculates all kind of derivative required in our problem for
c a given grid function
c all O(h^2) approximation
c----------------------------------------------------------------
        subroutine calcallDiv(f_a,   f ,    f_r ,
     &                        dx ,   dt,    n   ,
     &                        f_x,   f_t,   f_xx, f_tt , f_xt)

        implicit none

        integer n
        real*8 f_a(1:n), f(1:n), f_r(1:n)
        real*8 dx, dt
        real*8 f_x(1:n), f_t(1:n), f_xx(1:n), f_tt(1:n), f_xt(1:n)

        call Divx(f, dx, n, f_x)
        call Divt(f_a, f_r, dt, n, f_t)
        call Divtt(f_a, f, f_r, dt, n, f_tt)
        call Divxx(f, dx, n, f_xx)
        call Divxt(f_a, f_r, dx, dt, n, f_xt)

        return

        end
c-----------------------------------------------------------------
c calculates x derivative of f using left and right values O(h^2)
c assuming periodic boundry condition
c-----------------------------------------------------------------

         subroutine Divx(f, dx, n, f_x)

         implicit none

         integer n, i
         real*8 f(1:n), f_x(1:n)
         real*8 dx

         do i=2, n-1
            f_x(i) = ( f(i+1) - f(i-1) ) / (2*dx)
         enddo

         i = 1
            f_x(i) = ( f(i+1) - f(n-1) ) / (2*dx)

         i = n
            f_x(i) = ( f(1+1) - f(i-1) ) / (2*dx)

         return

         end
c-------------------------------------------------------------------
c calculates time derivative of f using advanced and retarded values
c O(h^2) approximation
c-------------------------------------------------------------------

         subroutine Divt(f_a, f_r, dt, n, f_t)

         implicit none
         integer n, i
         real*8 dt
         real*8 f_a(1:n), f_r(1:n), f_t(1:n)

         do i=1, n
             f_t(i) = ( f_a(i) - f_r(i) ) / (2*dt)
         enddo

         return

         end
c---------------------------------------------------------------------
c  calculates second time derivative of f using advanced and retarded
c  and current values. O(h^2) approximation
c---------------------------------------------------------------------

        subroutine Divtt(f_a, f, f_r, dt, n, f_tt)

        implicit none

        real*8 dt
        integer n, i
        real*8 f_a(1:n), f(1:n), f_r(1:n), f_tt(1:n)

        do i=1, n
           f_tt(i) = ( f_a(i) - 2*f(i) + f_r(i) ) / (dt*dt)
        enddo

        return

        end
c----------------------------------------------------------------
c calculates second x derivative of f using left and right values
c O(h^2) approximation
c----------------------------------------------------------------

        subroutine Divxx(f, dx, n, f_xx)

        implicit none
        integer n, i
        real*8 dx
        real*8 f(1:n), f_xx(1:n)

        do i=2, n-1
            f_xx(i) = ( f(i+1) - 2*f(i) + f(i-1) ) / (dx*dx)
        enddo

        i = 1
            f_xx(i) = ( f(i+1) - 2*f(i) + f(n-1) ) / (dx*dx)

        i = n
            f_xx(i) = ( f(1+1) - 2*f(i) + f(i-1) ) / (dx*dx)

        return

        end
c--------------------------------------------------------------
c calculates mixed x-t derivative of f using a/r values
c O(h^2) approximation
c--------------------------------------------------------------

        subroutine Divxt(f_a, f_r, dx, dt, n, f_xt)

        implicit none
        integer n, i
        real*8 dx, dt
        real*8 f_a(1:n), f_r(1:n), f_xt(1:n)

        do i=2, n-1
           f_xt(i) = ( f_a(i+1) - f_a(i-1) - f_r(i+1) + f_r(i-1) )
     &                      / (4*dt*dx)
        enddo

        i = 1
           f_xt(i) = ( f_a(i+1) - f_a(n-1) - f_r(i+1) + f_r(n-1) )
     &                      / (4*dt*dx)

        i = n
           f_xt(i) = ( f_a(1+1) - f_a(i-1) - f_r(1+1) + f_r(i-1) )
     &                      / (4*dt*dx)

        return

        end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                          SPHEREPACK                         .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file advec.f
c
c     program advec solves the time-dependent linear advection
c     equation for geopotential phi using the SPHEREPACK software
c
c          d(phi)/dt = -(u,v) DOT gradient(phi)
c
c                    = -(u*gdphl + v*gdpht)
c
c ... required files
c
c     gradgc.f,shagc.f,shsgc.f,vhsgc.f,sphcom.f hrfft.f,gaqd.f
c
c
c definitions:
c
c
c     nlat          number of gaussian latitudes excluding poles
c     nlon          number of distinct longitudes
c     omega         rotation rate of earth in radians per second
c     alpha         angle between axis of rotation and the coordinate
c                   axis
c     beta          latitude of the cosine bell
c     aa            radius of earth in meters
c     ncycle        cycle number
c     time          model time in seconds
c     dt            time step
c     lambda        longitude
c     theta         latitude
c
c   the first dimension of the following two dimensional arrays
c   corresponds to the latitude index with values i=1,...,nlat
c   where i=1 is the northern most gaussian point thetag(i)
c   and i=nlat is the southern most gaussian point thetag(nlat).
c   the second dimension is longitude with values j=1,...,nlon
c   where j=1 corresponds to zero longitude and j=nlon corresponds
c   to 2pi minus 2pi/nlon.
c
c
c     thetag(i)    vector of gaussian points on the full sphere which
c                  have north to south orientation as i=1,...,nlat
c
c     u(i,j)       east longitudinal velocity component
c     v(i,j)       latitudinal velocity component
c
c     phi(i,j)     the geopotential at t = time
c
c     phnew(i,j)   the geopotential at t=time+dt
c
c     phold(i,j)   the geopotential at t=time-dt
c
c     gdphl(i,j)   the longitudinal derivative component of
c                  the gradient of phi
c
c                       gdphl = 1/(cos(theta))*d(phi)/dlambda

c
c     gdpht(i,j)   the latitudinal derivative component of
c                  the gradient of phi
c
c                       gdpht = d(phi)/dtheta

c
c   the following two dimensional arrays are nonzero in the triangle
c   n=1,...,nlat and m less than or equal to n.
c
c     ar(m,n),br(m,n)    spectral coefficients of phi
c
      program advec
c
c     set grid size with parameter statements
c
      integer nnlat,nnlon,nn15,llwork,lldwork,llvhsgc,llshagc
      integer nlat,nlon,lwork,ldwork,lvhsgc,lshagc

c     parameter (nnlat=12,nnlon=23,ddt=1200.)
      parameter (nnlat=23,nnlon=45,ddt=600.)
c     parameter (nnlat=45,nnlon=90,ddt=300.)
c
c     set saved and unsaved work space lengths in terms of nnlat,nnlon
c     (see documentation for shagc,vhsgc,vhsgci,gradgc for estimates)
c
      parameter (nn15=nnlon+15)
      parameter(llwork=4*nnlat*nnlon+2*nnlat*(nnlat+1))
      parameter (lldwork = 2*nnlat*(nnlat+1)+1 )
      parameter (llvhsgc = 7*nnlat*nnlat+nnlon+15)
      parameter (llshagc = 5*nnlat*nnlat + nnlon+15)
c
c     dimension arrays
c
      real u(nnlat,nnlon),v(nnlat,nnlon)
      real phold(nnlat,nnlon),phnew(nnlat,nnlon),phi(nnlat,nnlon)
      real pexact(nnlat,nnlon)
      real dpdt(nnlat,nnlon)
      real gdphl(nnlat,nnlon),gdpht(nnlat,nnlon), work(llwork)
      double precision dwork(lldwork)
      real wshagc(llshagc),wvhsgc(llvhsgc),wshsgc(llshagc)
      real ar(nnlat,nnlat),br(nnlat,nnlat)
      real thetag(nnlat),colat(nnlat)
      double precision dtheta(nnlat),dwts(nnlat)
c
c     set constants
c
      pi = 4.0*atan(1.0)
      omega = (pi+pi)/(12.*24.*3600.)
      p0 = 1000.
      re = 1.0/3.0
      hzero = 1000.
      alphad = 60.
      alpha = pi*alphad/180.
      beta = pi/6.
c
c     set one array and no equatorial symmetry
c
      nt = 1
      isym = 0
c
c     set time step depending on resolution
c
      dt = ddt
      tdt = dt+dt
c
c     set work space length arguments
c
      lwork = llwork
      ldwork = lldwork
      lshagc = llshagc
      lvhsgc = llvhsgc
c
c     set grid size arguments
c
      nlat = nnlat
      nlon = nnlon
c
c     compute nlat latitudinal gaussian points in thetag  with
c     north to south orientation using gaqd from SPHEREPACK
c
      call gaqd(nlat,dtheta,dwts,DWORK,ldwork,ier)
      do  i=1,nlat
	thetag(i) = 0.5*pi- dtheta(i)
	colat(i) = dtheta(i)
      end do
c
c     preset saved work spaces for gradgc and shagc and shsgc
c
      call vhsgci(nlat,nlon,wvhsgc,lvhsgc,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,10) ierror
 10   format(' error in vsgci = ',i5)
      call shagci(nlat,nlon,wshagc,lshagc,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,20) ierror
 20   format(' error in shagci = ',i5)
      call shsgci(nlat,nlon,wshsgc,lshagc,dwork,ldwork,ierror)
      if(ierror .ne. 0) write(*,21) ierror
 21   format(' error in shsgci = ',i5)
c
c     set vector velocities and cosine bell in geopotential
c
      ca = cos(alpha)
      sa = sin(alpha)
      dlon = (pi+pi)/nlon
      do j=1,nlon
       xlm = (j-1)*dlon
       sl = sin(xlm)
       cl = cos(xlm)
       do i=1,nlat
        st = cos(colat(i))
        ct = sin(colat(I))
        sth = ca*st+sa*ct*cl
        cthclh = ca*ct*cl-sa*st
        cthslh = ct*sl
        xlhat = atanxy(cthclh,cthslh)
        clh = cos(xlhat)
        slh = sin(xlhat)
        cth = clh*cthclh+slh*cthslh
        uhat = omega*cth
        u(i,j) = (ca*sl*slh+cl*clh)*uhat
        v(i,j) = (ca*st*cl*slh-st*sl*clh+sa*ct*slh)*uhat
       end do
      end do
c
c       compute geopotential at t=-dt in phold and at t=0.0 in phi
c       to start up leapfrog scheme
c
	call gpot(-dt,alpha,beta,omega,hzero,re,nlat,nlon,
     +                                    nlat,colat,phold)
	call gpot(0.,alpha,beta,omega,hzero,re,nlat,nlon,
     +                                    nlat,colat,phi)
c
c     smooth geopotential at t=-dt and t=0. by synthesizing after analysis
c
	call shagc(nlat,nlon,isym,nt,phold,nlat,nlon,ar,br,nlat,
     +             nlat,wshagc,lshagc,work,lwork,ierror)
	if (ierror .ne.0) write(*,26) ierror
	call shsgc(nlat,nlon,isym,nt,phold,nlat,nlon,ar,br,nlat,
     +             nlat,wshsgc,lshagc,work,lwork,ierror)
	if (ierror .ne.0) write(*,28) ierror
	call shagc(nlat,nlon,isym,nt,phi,nlat,nlon,ar,br,nlat,
     +             nlat,wshagc,lshagc,work,lwork,ierror)
	if (ierror .ne.0) write(*,26) ierror
	call shsgc(nlat,nlon,isym,nt,phi,nlat,nlon,ar,br,nlat,
     +             nlat,wshsgc,lshagc,work,lwork,ierror)
	if (ierror .ne.0) write(*,28) ierror
 28     format(' ierror in shsgc = ',i5)
c
c     compute l2 and max norms of geopotential at t=0.
c
	p2 = 0.0
	pmax = 0.0
	do j=1,nlon
	 do i=1,nlat
	  pmax = amax1(abs(phi(i,j)),pmax)
	  p2 = p2 + phi(i,j)**2
	 end do
	end do
	p2 = sqrt(p2)
c
c     set number of time steps for 12 days
c     (time to circumvent the earth)
c
      ntime = int((12.*24.*3600.)/dt+0.5)
      mprint = ntime/12
      time = 0.0
      ncycle = 0
      do k=1,ntime+1
c
c       compute harmonic coefficients for phi at current time
c
	call shagc(nlat,nlon,isym,nt,phi,nlat,nlon,ar,br,nlat,
     +             nlat,wshagc,lshagc,work,lwork,ierror)
	if (ierror .ne.0) write(*,26) ierror
 26     format(' ierror in shagc = ',i5)
c
c       compute gradient of phi at current time
c
	call gradgc(nlat,nlon,isym,nt,gdpht,gdphl,nlat,nlon,ar,br,
     +               nlat,nlat,wvhsgc,lvhsgc,work,lwork,ierror)
	if (ierror .ne.0) write(*,27) ierror
 27     format(' ierror in gradgc = ',i5)
c
c       compute the time derivative of phi, note that the sign
c       of the last term is positive because the gradient is
C       computed with respect to colatitude rather than latitude.
c
	do j=1,nlon
	  do i=1,nlat
	    dpdt(i,j) = -u(i,j)*gdphl(i,j) + v(i,j)*gdpht(i,j)
	  end do
	end do
c
      if (mod(ncycle,mprint) .eq. 0) then
c
c     write variables
c
      err2 = 0.0
      errm = 0.0
      call gpot(time,alpha,beta,omega,hzero,re,nlat,nlon,nlat,
     +          colat,pexact)
      do j=1,nlon
	do i=1,nlat
	   err2 = err2 + (pexact(i,j)-phi(i,j))**2
	   errm = amax1(abs(pexact(i,j)-phi(i,j)),errm)
	end do
      end do
      errm = errm/pmax
      err2 = sqrt(err2)/p2
      htime = time/3600.
      write(*,390) ncycle,htime,dt,nlat,nlon,omega,hzero,
     1             alphad,errm,err2
  390 format(//' advecting cosine bell, test case 2',/
     1        ,' cycle number              ',i10
     2        ,' model time in  hours      ',f10.2/
     3        ,' time step in seconds      ',f10.0
     4        ,' number of latitudes       ',i10/
     5        ,' number of longitudes      ',i10
     6        ,' rotation rate        ',1pe15.6/
     7        ,' mean height          ',1pe15.6
     8        ,' tilt angle                ',0pf10.2/
     9        ,' max geopot. error    ',1pe15.6
     1        ,' RMS geopot. error    ',1pe15.6)

      end if
	time = time + dt
	ncycle = ncycle+1
c
c       update phold,phi for next time step
c
	do j=1,nlon
	  do i=1,nlat
	    phnew(i,j) = phold(i,j) + tdt*dpdt(i,j)
	    phold(i,j) = phi(i,j)
	    phi(i,j) = phnew(i,j)
	  end do
	end do
c
c     end of time loop
c
      end do
      end
      subroutine gpot(t,alpha,beta,omega,hzero,re,nlat,nlon,idim,
     +                colat,h)
c
c     computes advecting cosine bell on a tilted grid a time t.
c
c input parameters
c
c     t      time in seconds
c
c     alpha  tilt angle in radians
c
c     beta   colatitude of cosine bell in untilted coordinate
c            system in radians
c
c     omega  angular velocity in radians per second
c
c     hzero  maximum value of cosine bell
c
c     re     radius of support for cosine bell in radians
c
c     nlat   number of latitudes including the poles
c
c     nlon   number of distinct longitude lines
c
c     idim   first dimension of output array h
c
c     colat  vector of Gauss colatitude grid points
c
c output parameter
c
c     h      an nlat by nlon array containing the geopotential
c
c             on a tilted grid
c
      dimension h(idim,nlon),colat(nlat)
      real lambda,lambdc,lhat
      lambdc = omega*t
      call stoc(1.,beta,lambdc,xc,yc,zc)
      ca = cos(alpha)
      sa = sin(alpha)
      pi = 4.*atan(1.)
      tpi = pi+pi
      dlon = tpi/nlon
      do 10 j=1,nlon
      lambda = (j-1)*dlon
      cl = cos(lambda)
      sl = sin(lambda)
      do 10 i=1,nlat
      theta = colat(i)
      st = cos(theta)
      ct = sin(theta)
      sth = ca*st+sa*ct*cl
      cthclh = ca*ct*cl-sa*st
      cthslh = ct*sl
      lhat = atanxy(cthclh,cthslh)
      clh = cos(lhat)
      slh = sin(lhat)
      cth = clh*cthclh+slh*cthslh
      that = atanxy(sth,cth)
      call stoc(1.,that,lhat,x1,y1,z1)
      dist = sqrt((x1-xc)**2+(y1-yc)**2
     1           +(z1-zc)**2)
      h(i,j) = 0.
      if(dist .ge. re) go to 10
      r = 2.*asin(dist/2.)
      if(r .ge. re) go to 10
      h(i,j) = hzero*.5*(cos(r*pi/re)+1.)
 10   continue
      return
      end
      function atanxy(x,y)
      atanxy = 0.
      if(x.eq.0. .and. y.eq.0.) return
      atanxy = atan2(y,x)
      return
      end
      subroutine ctos(x,y,z,r,theta,phi)
      r1 = x*x+y*y
      if(r1 .ne. 0.) go to 10
      phi = 0.
      theta = 0.
      if(z .lt. 0.) theta = 4.*atan(1.)
      return
   10 r = sqrt(r1+z*z)
      r1 = sqrt(r1)
      phi = atan2(y,x)
      theta = atan2(r1,z)
      return
      end
      subroutine stoc(r,theta,phi,x,y,z)
      st = sin(theta)
      x = r*st*cos(phi)
      y = r*st*sin(phi)
      z = r*cos(theta)
      return
      end


! { dg-do run }
! PR 34566 - logical matmul used to give the wrong result.
! We check this by running through every permutation in
! multiplying two 3*3 matrices, and all permutations of multiplying
! a 3-vector and a 3*3 matrices  and checking against equivalence
! with integer matrix multiply.
program main
  implicit none
  integer, parameter :: ki=4
  integer, parameter :: dimen=3
  integer :: i, j, k
  real, dimension(dimen,dimen) :: r1, r2
  integer, dimension(dimen,dimen) :: m1, m2
  logical(kind=ki), dimension(dimen,dimen) :: l1, l2
  logical(kind=ki), dimension(dimen*dimen) :: laux
  logical(kind=ki), dimension(dimen) :: lv
  integer, dimension(dimen) :: iv

  do i=0,2**(dimen*dimen)-1
     forall (k=1:dimen*dimen)
        laux(k) = btest(i, k-1)
     end forall
     l1 = reshape(laux,shape(l1))
     m1 = ltoi(l1)

     ! Check matrix*matrix multiply
     do j=0,2**(dimen*dimen)-1
        forall (k=1:dimen*dimen)
           laux(k) = btest(i, k-1)
        end forall
        l2 = reshape(laux,shape(l2))
        m2 = ltoi(l2)
        if (any(matmul(l1,l2) .neqv. (matmul(m1,m2) /= 0))) then
          STOP 1
        end if
     end do

     ! Check vector*matrix and matrix*vector multiply.
     do j=0,2**dimen-1
        forall (k=1:dimen)
           lv(k) = btest(j, k-1)
        end forall
        iv = ltoi(lv)
        if (any(matmul(lv,l1) .neqv. (matmul(iv,m1) /=0))) then
          STOP 2
        end if
        if (any(matmul(l1,lv) .neqv. (matmul(m1,iv) /= 0))) then
          STOP 3
        end if
     end do
  end do

contains
  elemental function ltoi(v)
    implicit none
    integer :: ltoi
    real :: rtoi
    logical(kind=4), intent(in) :: v
    if (v) then
       ltoi = 1
    else
       ltoi = 0
    end if
  end function ltoi

end program main


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   opt :    A model algebraic optimization problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION X1,X2,X3,X4,X5

       X1=U(1)
       X2=PAR(1)
       X3=PAR(2)
       X4=PAR(3)
       X5=PAR(4)

       F(1)=X1*X1 + X2*X2 + X3*X3 + X4*X4 + X5*X5 - 1

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=2*X1

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DFDP(1,1)=2*X2
       DFDP(1,2)=2*X3
       DFDP(1,3)=2*X4
       DFDP(1,4)=2*X5

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION X1,X2,X3,X4,X5

       X1=1.0
       X2=0.0
       X3=0.0
       X4=0.0
       X5=0.0

       U(1)=X1

       PAR(1)=X2
       PAR(2)=X3
       PAR(3)=X4
       PAR(4)=X5

      END SUBROUTINE STPNT

      SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: FS
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM),DFDP(*)

      DOUBLE PRECISION X1,X2,X3,X4,X5

       X1=U(1)
       X2=PAR(1)
       X3=PAR(2)
       X4=PAR(3)
       X5=PAR(4)

       FS=X1 + X2 + X3 + X4 + X5

      IF(IJAC.EQ.0)RETURN

       DFDU(1)=1.0

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DFDP(1)=1.0
       DFDP(2)=1.0
       DFDP(3)=1.0
       DFDP(4)=1.0

      END SUBROUTINE FOPT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


DECIMAL

: FIB ( n1 -- n2 )
  DUP 2 < IF
    DROP 1
  ELSE
    DUP 1- RECURSE
    SWAP 2 - RECURSE
    +
  THEN
;

T{ 22 FIB -> 28657 }T


program test_pic_3d

use mesh_fields_m
use poisson_3d_m
use output_m
use particles_m
use compute_rho_cic_m
use interpolation_cic_m

implicit none

type(mesh_t)       :: mesh
type(fields_3d_t)  :: fields
type(poisson_3d_t) :: poisson
type(particles_t)  :: particles

integer,    parameter :: nx = 64, ny = 64, nz = 4
integer(8), parameter :: nbpart = nx * ny * 100
real(8)               :: xmin, xmax, ymin, ymax, zmin, zmax
real(8)               :: pi
integer               :: i, j, k, m
real(8)               :: x, y, z
real(8)               :: dx, dy, dz
real(8)               :: err_x, err_y, err_z

pi = 4d0 * atan(1d0)

xmin = 0d0
xmax = 18d0
ymin = 0d0
ymax = 18d0
zmin = 0d0
zmax = 1d0

call init_mesh( mesh, xmin, xmax, nx, ymin, ymax, ny, zmin, zmax, nz )

dx = mesh%dx
dy = mesh%dy
dz = mesh%dz

call init_fields( fields, mesh )

call init_poisson( poisson, mesh)

print*, " number of particles = ", nbpart

call init_particles_3d( particles, nbpart, mesh )

call compute_rho_cic( fields, particles)

print*, sum(fields%rho) * dx * dy * dz, nbpart * particles%w

call solve_poisson( poisson, fields)

call write_data( 1, fields)

do k = 1, nz+1
    z = (k-1) * dz
    do j = 1, ny+1
        y = (j-1) * dy
        do i = 1, nx+1
            x = (i-1) * dx
            fields%e(1,i,j,k) = sin(x)
            fields%e(2,i,j,k) = sin(y)
            fields%e(3,i,j,k) = sin(z)
        end do
    end do
end do

call interpolate_eb_cic( particles, fields)

err_x = 0d0
err_y = 0d0
err_z = 0d0

do m = 1, nbpart
    x = (i-1) * mesh%dx
    err_x = err_x + abs(particles%e(1,m) - sin(particles%x(1,m)))
    err_y = err_y + abs(particles%e(2,m) - sin(particles%x(2,m)))
    err_z = err_z + abs(particles%e(3,m) - sin(particles%x(3,m)))
end do

print*, err_x/nbpart, err_y/nbpart, err_z/nbpart

end


program main
    implicit none

    integer :: x(1:6) = (/ 3, 4, 5, 6, 7, 8 /)
    integer :: i
    integer, dimension(size(x)) :: res
    res = [(square(x(i)), i = 1, size(x))]

    write(*, *) res

    contains
    function square(x) result(res)
        implicit none
        integer, intent(in) :: x
        integer :: res
        !integer, intent(out) :: res
        res = x * x
    end function square

end program main


!___________________________________________________________________________
!     --- Module for 2D Quadratic Elements (8 nodes, 4 int)  (quad2D.f90)
!     --- sets shape functions and their gradients in local sys
!     --- same for all elem of this type (=> called 1x at start)
!     --- for now ASSUMES QUADRILATERAL ELEMENTS ONLY (OR DEGEN)
!     --- distribution R1.0, Lucas Brouwer 11/15/2018
!___________________________________________________________________________

MODULE quad2D

IMPLICIT NONE

PRIVATE
!     element characteristics
  INTEGER nnode,edim,nq1D,etype,nq
	PARAMETER (nnode=8)
	PARAMETER (edim=2)          ! 2D element
	PARAMETER (nq1D=2)          ! # guassian point integration (in 1D)
	PARAMETER (etype=2)         ! 1 = linear shape functions, 2 = quadratic shape functions (midside)
	PARAMETER (nq=4)            ! nq1D^edim

!     quadrature and shape functions (set 1x)
	DOUBLE PRECISION qw(nq),dH(nnode,edim,nq)
	DOUBLE PRECISION qpt(edim,nq),HH(nq,nq),H(nnode,nq)

!     SUBROUTINEs
	PUBLIC set_dH,set_quad,set_HH
	PUBLIC qw,dH,HH,H
	PUBLIC nnode,edim,nq
	PUBLIC INVF2

CONTAINS

!___________________________________________________________________________
!     --- shape function gradients w.r.t local var (at quad points)
!___________________________________________________________________________

	SUBROUTINE set_dH()
		DOUBLE PRECISION r,s,t
		INTEGER i

!	set dH based on shape function gradients w.r.t local var (at quad points)

		DO i = 1,nq
			t = qpt(1,i)
			s = qpt(2,i)

!           2D 4 node element (linear)
! 					dh(1,1,i) = +0.25d0*(1.d0+s)
! 					dh(2,1,i) = +0.25d0*(-1.d0-s)
! 					dh(3,1,i) = +0.25d0*(-1.d0+s)
! 					dh(4,1,i) = +0.25d0*(1.d0-s)
!
! 					dh(1,2,i) = +0.25d0*(1.d0+r)
! 					dh(2,2,i) = +0.25d0*(1.d0-r)
! 					dh(3,2,i) = +0.25d0*(-1.d0+r)
! 					dh(4,2,i) = +0.25d0*(-1.d0-r)

!           2D 8 node element (quadratic)
			H(1,i) = +0.25d0*(+1.d0-s)*(+1.d0-t)*(-s-t-1.d0)
			H(2,i) = +0.25d0*(+1.d0+s)*(+1.d0-t)*(+s-t-1.d0)
			H(3,i) = +0.25d0*(+1.d0+s)*(+1.d0+t)*(+s+t-1.d0)
			H(4,i) = +0.25d0*(+1.d0-s)*(+1.d0+t)*(-s+t-1.d0)
			H(5,i) = +0.5d0*(+1.d0-s*s)*(+1.d0-t)
			H(6,i) = +0.5d0*(+1.d0+s)*(+1.d0-t*t)
			H(7,i) = +0.5d0*(+1.d0-s*s)*(+1.d0+t)
			H(8,i) = +0.5d0*(+1.d0-s)*(+1.d0-t*t)

!     2D 8 node element (quadratic)
			dH(1,1,i) = -0.25d0*(-1.d0+t)*(2.d0*s+t)
			dH(2,1,i) = -0.25d0*(-1.d0+t)*(2.d0*s-t)
			dH(3,1,i) = +0.25d0*(+1.d0+t)*(2.d0*s+t)
			dH(4,1,i) = +0.25d0*(+1.d0+t)*(2.d0*s-t)
			dH(5,1,i) = s*(-1.d0+t)
			dH(6,1,i) = +0.5d0*(+1.d0-t*t)
			dH(7,1,i) = -s*(+1.d0+t)
			dH(8,1,i) = +0.5d0*(-1.d0+t*t)

			dH(1,2,i) = -0.25d0*(-1.d0+s)*(+2.d0*t+s)
			dH(2,2,i) = -0.25d0*(+1.d0+s)*(-2.d0*t+s)
			dH(3,2,i) = +0.25d0*(+1.d0+s)*(+2.d0*t+s)
			dH(4,2,i) = +0.25d0*(-1.d0+s)*(-2.d0*t+s)
			dH(5,2,i) = +0.5d0*(-1.d0+s*s)
			dH(6,2,i) = -t*(+1.d0+s)
			dH(7,2,i) = +0.5d0*(+1.d0-s*s)
			dH(8,2,i) = t*(-1.d0+s)
		ENDDO

		RETURN
	END SUBROUTINE set_dH

!___________________________________________________________________________
!     --- set quadrature points and weights
!___________________________________________________________________________

	SUBROUTINE set_quad()
		INTEGER i
		INTEGER permr(4),perms(4)
		DOUBLE PRECISION P(nq1D),W(nq1D)
! set up gaussian point locations and weights (1D)
		W(1) = 1.0d0
		W(2) = 1.0d0
		P(1) = dsqrt(1.0d0/3.0d0)
		P(2) = -dsqrt(1.0d0/3.0d0)

!   permute to get
!    4   3
!    1   2
		permr = (/1,2,2,1/)
		perms = (/1,1,2,2/)
	  DO i=1,nq
				qpt(1,i) = P(permr(i))
				qpt(2,i) = P(perms(i))
				qw(i) = W(permr(i))*W(perms(i))
	  ENDDO

		RETURN
	END SUBROUTINE set_quad

!___________________________________________________________________________
!     --- extrapolation of solution var from quad points to corner nodes
!___________________________________________________________________________

	SUBROUTINE set_HH()
		DOUBLE PRECISION S3
!	set HH which extrapolates scalars from guass points to corners	(assumes 4 quad points)
		S3 = dsqrt(3.0d0)

		HH(1,1) = 1.0d0+0.5d0*S3
		HH(1,2) = -0.5d0
		HH(1,3) = 1.0d0-0.5d0*S3
		HH(1,4) = -0.5d0

		HH(2,1) = -0.5d0
		HH(2,2) = 1.0d0+0.5d0*S3
		HH(2,3) = -0.5d0
		HH(2,4) = 1.0d0-0.5d0*S3

		HH(3,1) = 1.0d0-0.5d0*S3
		HH(3,2) = -0.5d0
		HH(3,3) = 1.0d0+0.5d0*S3
		HH(3,4) = -0.5d0

		HH(4,1) = -0.5d0
		HH(4,2) = 1.0d0-0.5d0*S3
		HH(4,3) = -0.5d0
		HH(4,4) = 1.0d0+0.5d0*S3

		RETURN
	END SUBROUTINE set_HH

!____________________________________________________________________
!	 Subroutine INVF2 - from Diego
!____________________________________________________________________
  SUBROUTINE INVF2(D,F,FINV,Jac)
    INTEGER D
    DOUBLE PRECISION F(D,D),FINV(D,D),Jac
		IF (D == 2) THEN
			Jac = F(1,1)*F(2,2) - F(1,2)*F(2,1)
			FINV(1,1) = F(2,2)/Jac
			FINV(2,2) = F(1,1)/Jac
			FINV(2,1) = -F(2,1)/Jac
			FINV(1,2) = -F(1,2)/Jac
		ELSE IF (D == 3) THEN
			Jac = F(1,1)*(F(2,2)*F(3,3) - F(2,3)*F(3,2)) - F(1,2)*(F(2,1)*F(3,3) - F(3,1)*F(2,3)) +	F(1,3)*(F(2,1)*F(3,2) - F(3,1)*F(2,2))
			FINV(1,1) =  (F(2,2)*F(3,3) - F(2,3)*F(3,2))/Jac
			FINV(2,1) = -(F(2,1)*F(3,3) - F(3,1)*F(2,3))/Jac
			FINV(3,1) =  (F(2,1)*F(3,2) - F(3,1)*F(2,2))/Jac
			FINV(1,2) = -(F(1,2)*F(3,3) - F(1,3)*F(3,2))/Jac
			FINV(2,2) =  (F(1,1)*F(3,3) - F(1,3)*F(3,1))/Jac
			FINV(3,2) = -(F(1,1)*F(3,2) - F(1,2)*F(3,1))/Jac
			FINV(1,3) =  (F(1,2)*F(2,3) - F(1,3)*F(2,2))/Jac
			FINV(2,3) = -(F(1,1)*F(2,3) - F(2,1)*F(1,3))/Jac
			FINV(3,3) =  (F(1,1)*F(2,2) - F(2,1)*F(1,2))/Jac
     ENDIF
     RETURN
  END SUBROUTINE INVF2

END MODULE quad2D


program elliptic
implicit none
integer::i,j,nitr,nx,ny,nom,k
real*8 ::dx,dy,x0,xL,y0,yL,omega,tol
real*8::dom,lmax,pi,optom,om1,om2
real*8,allocatable ::u(:,:),x(:),y(:),e(:,:)

!Domain
x0 = 0.0d0 !left
xL = 2.0d0 !right

y0 = 0.0d0 !bottom
yL = 1.0d0 !up

!number of points
nx = 20
ny = 10

!grid spacing (spatial)
dx = (xL-x0)/dfloat(nx)
dy = (yL-y0)/dfloat(ny)

!spatial coordinates
allocate(x(0:nx))
do i=0,nx
x(i) = x0 + dfloat(i)*dx
end do

allocate(y(0:ny))
do j=0,ny
y(j) = y0 + dfloat(j)*dy
end do

allocate(e(0:nx,0:ny))
pi = 4.0d0*datan(1.0d0)

!Iterative schemes to solve Laplace Equation:
allocate(u(0:nx,0:ny))

open(19,file='error.plt')
write(19,*) 'variables ="n","Error"'

open(20,file='nitr.plt')
write(20,*) 'variables ="w","N-ITR"'

!Tolerance
tol = 1.0d-10

!Compute with various omega and plot number of iterations required by the specified omega
om1=1.0d0
om2=1.95d0
dom = 0.05d0
nom = 19

do k=0,nom

  	!initial guess which satisfies boundary condtions
	!Homogeneous Drichlet B.C.
	!we are not updating boundary points, they are zero
	do j=0,ny
	do i=0,nx
	u(i,j) = 0.0d0
	end do
	end do

  	omega = om1 + dfloat(k)*dom

	call SOR(nx,ny,y,u,omega,tol,nitr) !Successive over relaxation (SOR)

	!write error
    write(*,*)'omega and total interval:'
    write(20,*) omega, nitr
    write(*,*) omega, nitr
end do

!call GS(nx,ny,y,u,tol,nitr)    !Gauss-Seidel (GS)

close(20)
close(19)

lmax=0.5d0*(dcos(pi/dfloat(nx))+dcos(pi/dfloat(ny)))
optom=2.0d0/(1.0d0 + dsqrt(1-lmax**2))

print*,"-------------------------"
print*,"optimum omega = ", optom
print*,"-------------------------"

open(200,file='field.plt')
write(200,*)'variables ="x","y","u"'
write(200,*)'zone f=point i=',nx+1,',j=',ny+1
do j=0,ny
do i=0,nx
write(200,*) x(i),y(j),u(i,j)
end do
end do
close(200)

end

!-----------------------------------------------------------------------------!
!Gauss-Seidel (GS)
!-----------------------------------------------------------------------------!
subroutine GS(nx,ny,y,u,tol,nitr)
implicit none
integer::nx,ny,i,j,nitr
real*8 ::tol,err,omega
real*8 ::u(0:nx,0:ny),e(0:nx,0:ny),v(0:nx,0:ny),y(0:ny)

omega = 1.0d0

nitr = 0
err = 1.0d0

do while(err.gt.tol)

	nitr = nitr + 1

    !dirichlet boundary condition
 do j=0,ny
    u(0,j) = y(j)
 end do

 do i = 1,9
   u(i,ny) = 1.0d0
 end do

    do j=0,ny
	do i=0,nx
	v(i,j) = u(i,j)
	end do
	end do

	!update
    do j=1,ny-1
	do i=1,nx-1
	u(i,j) = v(i,j) + ((omega/4.0d0)*(v(i+1,j)+u(i-1,j)+v(i,j+1)+u(i,j-1)-(4.0d0*v(i,j))))
	end do
	end do

    !neumann boundary condition
    do j = 1,5
      u(nx,j) = (1.0d0/11.0d0)*(18.0d0*u(nx-1,j) - 9.0d0*u(nx-2,j) + 2.0d0*u(nx-3,j))
    end do

   do j = 5,ny
   do i = 10,nx
     u(i,j) = 1.0d0
   end do
 end do

    !compute error
 	do j=0,ny
	do i=0,nx
	e(i,j) = dabs(u(i,j)-v(i,j))
	end do
	end do
    !max value of the error
        err = maxval(e)

	!write error
    write(19,*) nitr, err
    write(*,*) nitr, err

end do

end

!-----------------------------------------------------------------------------!
!Successive over relaxation (SOR)
!-----------------------------------------------------------------------------!
subroutine SOR(nx,ny,y,u,omega,tol,nitr)
implicit none
integer::nx,ny,i,j,nitr
real*8 ::tol,err,omega
real*8 ::u(0:nx,0:ny),e(0:nx,0:ny),v(0:nx,0:ny),y(0:ny)

nitr = 0
err=1.0d0

do while(err.gt.tol)

	nitr = nitr + 1

!dirichlet boundary condition
 do j=0,ny
    u(0,j) = y(j)
 end do

 do i = 1,9
   u(i,ny) = 1.0d0
 end do

    do j=0,ny
	do i=0,nx
	v(i,j) = u(i,j)
	end do
	end do

	!update
    do j=1,ny-1
	do i=1,nx-1
	u(i,j) = v(i,j) + (omega/4.0d0)*(v(i+1,j)+u(i-1,j)+v(i,j+1)+u(i,j-1)-(4.0d0*v(i,j)))
	end do
	end do

    ! Neumann boundary condition
    do j = 1,5
      u(nx,j) = (1.0d0/11.0d0)*(18.0d0*u(nx-1,j) - 9.0d0*u(nx-2,j) + 2.0d0*u(nx-3,j))
    end do

   do j = 5,ny
   do i = 10,nx
     u(i,j) = 1.0d0
   end do
 end do

    !compute error
 	do j=0,ny
	do i=0,nx
	e(i,j) = dabs(u(i,j)-v(i,j))
	end do
	end do
    !max value of the error
    err = maxval(e)

end do
end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DOHRFF (Double Orthogonal Hessenberg matrix Reduction to Factored Form)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine factors a real orthogonal upper hessenberg matrix into
! a sequence of Givens' rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  H               REAL(8) array of dimension (N,N)
!                    orthogonal hessenberg matrix to be reduced
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for Givens' rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies COMPZ is invalid
!                    INFO = -2 implies N is invalid
!                    INFO = -3 implies H is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DOHRFF(N,H,Q,D,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: H(N,N), Q(2*(N-1)), D(2*N)
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii, ind
  real(8) :: nrm, tol
  real(8) :: c, s

  ! initialize info
  INFO = 0

  ! check N
  call IARNAN(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -1
    return
  end if
  call IARINF(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -1
    return
  end if
  if (N < 2) then
    INFO = -1
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
    end if
    return
  end if

  ! check H
  call DARACH2(N,N,H,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"H is invalid",INFO,INFO)
    end if
    INFO = -2
    return
  end if

  ! set tol
  tol = dble(max(10,N))*epsilon(1d0)

  ! loop for reduction
  ! ii is the column being reduced
  do ii=1,(N-1)

    ! reduce to block diagonal
    call DARCG22(H(ii,ii),H(ii+1,ii),c,s,nrm,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARCG22 failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! check for unitarity
    if (abs(nrm-1d0) >= tol) then
      INFO = -3
      ! print error in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"H is not orthogonal",INFO,INFO)
      end if
      return
    end if

    ! update H
    H(ii,ii) = c*H(ii,ii) + s*H(ii+1,ii)
    H(ii+1,(ii+1):N) = -s*H(ii,(ii+1):N) + c*H(ii+1,(ii+1):N)

    ! store in Q
    Q(2*(ii-1)+1) = c
    Q(2*(ii-1)+2) = s

    ! store in D
    D(2*(ii-1)+1) = sign(1d0,H(ii,ii))
    D(2*(ii-1)+2) = 0d0

  end do

  ! check for unitarity
  if (abs(abs(H(N,N))-1d0) >= tol) then
    INFO = -3
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"H is not orthogonal",INFO,INFO)
    end if
    return
  end if

  ! store in D
  D(2*(N-1)+1) = sign(1d0,H(N,N))
  D(2*(N-1)+2) = 0d0

end subroutine DOHRFF


      SUBROUTINE RK4(Y,DYDX,N,X,H,YOUT,DERIVS)
      PARAMETER (NMAX=10)
      DIMENSION Y(N),DYDX(N),YOUT(N),YT(NMAX),DYT(NMAX),DYM(NMAX)
      HH=H*0.5
      H6=H/6.
      XH=X+HH
      DO 11 I=1,N
        YT(I)=Y(I)+HH*DYDX(I)
11    CONTINUE
      CALL DERIVS(XH,YT,DYT)
      DO 12 I=1,N
        YT(I)=Y(I)+HH*DYT(I)
12    CONTINUE
      CALL DERIVS(XH,YT,DYM)
      DO 13 I=1,N
        YT(I)=Y(I)+H*DYM(I)
        DYM(I)=DYT(I)+DYM(I)
13    CONTINUE
      CALL DERIVS(X+H,YT,DYT)
      DO 14 I=1,N
        YOUT(I)=Y(I)+H6*(DYDX(I)+DYT(I)+2.*DYM(I))
14    CONTINUE
      RETURN
      END


module m_time
  !! Contains functions that handle time

use variableKind, only: i32, i64, r64

implicit none

contains

  !=====================================================================!
  function daysInMonth(month,year) result(days)
    !! Get the number of days in a month. Accounts for leap years
  !=====================================================================!
  integer(i32) :: month
    !! How many days in this month
  integer(i32),optional :: year
    !! Check if a leap year?
  integer(i32) :: days
    !! Number of days
  days=0
  select case(month)
  case(1,3,5,7,8,10,12)
    days=31
  case(2)
    days=28
    if (present(year)) then
      if (isLeapYear(year)) days=29
    endif
  case(4,6,9,11)
    days=30
  end select

  end function
  !=====================================================================!
  !=====================================================================!
  function daysInYear(year) result(days)
    !! Get the number of days in a year, accounts for leap years
  !=====================================================================!
  integer(i32) :: year
    !! How many days in this year
  integer(i32) :: days
    !! Number of days
  days=365
  if (isLeapYear(year)) days=366
  end function
  !=====================================================================!
  !=====================================================================!
  function isLeapYear(year) result(yes)
    !! Determine whether the year is a leap year
  !=====================================================================!
  integer(i32) :: year
    !! Year to check
  logical :: yes
    !! is a leap year
  yes=.false.
  if (iand(year,3) == 0 .and. (mod(year,25) /= 0 .or. iand(year,15) == 0)) yes=.true.
  end function
  !=====================================================================!
  !=====================================================================!
  function secondsToHMS(t) result(res)
    !! Convert a time in seconds to HH:MM:SS.MSEC
  !=====================================================================!
  real(r64) :: t
    !! Time in seconds
  character(len=22) :: res
    !! Resulting string contains the time
  integer(i32) :: days,hrs,min,sec,msec
  real(r64)  :: tmp
  days=floor(t/86400.d0)
  tmp=t-(dble(days*86400))

  hrs=floor(tmp/3600.d0)
  tmp=tmp-(dble(hrs*3600))
  hrs=hrs+(24*days)

  min=floor(tmp/60.d0)
  tmp=tmp-(dble(min*60))

  sec=floor(tmp)
  msec=int(1000.d0*(tmp-(dble(sec))))

  write(res,10) hrs,min,sec,msec
10 format(i0,':',i2,':',i2,'.',i3,' (h:m:s)')
  end function
  !=====================================================================!
  !=====================================================================!
  function timeInSeconds(values) result(res)
    !! Convert hours minutes seconds etc. to seconds
  !=====================================================================!
  integer(i32) :: values(8)
    !! values containing amounts of days hours etc.
  real(r64) :: res
    !! time in seconds
  res = dble((86400*values(3))+(3600*values(5)) + (60*values(6)) + values(7))&
    + (0.001d0 * dble(values(8)))
  end function
  !=====================================================================!
  !=====================================================================!
  function timeToInteger(values) result(res)
    !! Convert hours minutes seconds etc. to an integer.  Use 64bit to prevent the 2038 problem.
  !=====================================================================!
  integer(i32) :: values(8)
    !! Values containing amounts of days hours etc.
  integer(i64) :: res
    !! Time as an integer.

  ! Account for leap years
  values(1) = values(1) * daysInYear(values(1))
  ! Accounts for different length months
  values(2) = values(2) * daysInMonth(values(2))

  res = ( values(1) * 86400000 & ! Years
      + values(2) * 86400000 & ! Months
      + values(3) * 86400000 & ! Days
      + values(5) * 3600000 & ! Hours
      + values(6) * 60000 & ! Minutes
      + values(7) * 1000 & ! Seconds
      + values(8)) ! Milliseconds
  end function
  !=====================================================================!
end module


      subroutine SSTOP(K, N, T, BCOEF, BDIF, NPC, XI, PC)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SSTOP Krogh  Changes to use M77CON
c>> 1992-10-27 SSTOP C. L. Lawson, JPL
c>> 1988-03-16 C. L. Lawson, JPL
c
c     Given coeffs, BCOEF(), rel to the B-spline basis, this subr
c     computes coeffs, PC(,), rel to the Power basis.
c     This code is an adaptation of lines 35-51 of
c     the subroutine, BSPLPP, given on pp. 140-141 of
c     A PRACTICAL GUIDE TO SPLINES by Carl De Boor, Springer-Verlag,
c     1978, however BSPLPP uses the Taylor basis and this subr uses
c     the Power basis.
c     ------------------------------------------------------------------
c     K     [in]  Order of the spline function.  Note that the
c           polynomial degree of the pieces of the spline function is
c           one less than the order.
c     N     [in]  Number of B-spline coefficients.
c     T()   [in]  Knot sequence defining the B-spline basis functions.
c           Contains N+K values, nondecreasing.  The "proper
c           interpolation interval" is from T(K) to T(N+1).
c     BCOEF()  [in]  N coefficients, defining a spline function relative
c           to the B-spline basis.
c     BDIF(,)  [scratch, out]  Array in which differences of the
c           B-spline coeffs will be stored.
c     NPC   [out]  NPC+1 is the number of distinct values among T(K)
c           through T(N+1).  NPC is the number of polynomial pieces
c           needed to define the spline function.  The number of
c           breakpoints returned in XI() will be NPC.
c     (XI(j), j = 1, ..., NPC+1)  [out]  Breakpoints for the Power
c           representation of the piecewise polynomial.
c           These will be the distinct values from among the knots,
c           T(K) through T(N+1).
c     ((PC(i,j), i = 1, ..., K), j = 1, ..., NPC)  [out]
c           PC(i,j) will be the (i-1)st derivative of the spline
c           function at XI(j).  Thus PC(i,j)/(factorial(i-1)) is the
c           coefficient of (x-XI(j))**(i-1)
c           in the polynomial piece defined over the interval from
c           XI(j) to XI(j+1).
c     ------------------------------------------------------------------
c--S replaces "?": ?STOP, ?SDIF, ?SVALA
c     ------------------------------------------------------------------
      integer I, ILEFT, NPC, K, N, NDERIV
      real             BCOEF(N), BDIF(N,K), DENOM, FAC
      real             ONE, PC(K,*), T(N+K), XI(*)
      parameter(ONE = 1.0e0)
c     ------------------------------------------------------------------
      NDERIV = K-1
      call SSDIF ( K, N, T, BCOEF, NDERIV, BDIF)
      NPC = 0
      XI(1) = T(K)
      do 50 ILEFT=K,N
         if (T(ILEFT+1) .ne. T(ILEFT)) then
            NPC = NPC + 1
            XI(NPC+1) = T(ILEFT+1)
c
c              SSVALA sets PC(I,NPC) to be the (I-1)st derivative of
c              the curve at XI(NPC) for I = 1, ..., K.
c              The subsequent loop divides the Jth derivative by
c              factorial(J).
c
            call SSVALA ( K, N, T, NDERIV, BDIF, XI(NPC), PC(1,NPC))
            DENOM = ONE
            FAC = ONE
            do 40 I = 3,K
               FAC = FAC + ONE
               DENOM = DENOM * FAC
               PC(I,NPC) = PC(I,NPC) / DENOM
   40       continue
         endif
   50 continue
      return
      end


!! 1D

!! setup the stencil struct matrix, A
subroutine stencil_ac_1d(nxyz, lamdaxyz, ng, A, soln, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix
    real    ::  theta, beta_, dtk, lamda
    real, dimension(      1-ng:nxyz(1)+ng ) :: soln
    real, dimension(1:3,  1-ng:nxyz(1)+ng ) :: A

    ix = nxyz(1)
    lamda = lamdaxyz(1)
    do i=1, ix
        A(1, i) = -theta*lamda
        A(2, i) = -theta*lamda
        A(3, i) = 1 + 2*theta*lamda + theta*dtk * (  &
              (soln(i)-1.0) * ( soln(i) - beta_ )  &
            + (soln(i)    ) * ( soln(i) - beta_  )  &
            + (soln(i)    ) * ( soln(i) - 1.0    )  )
    end do
end subroutine stencil_ac_1d

subroutine rhs_ac_1d(nxyz, lamdaxyz, ng, b, soln, soln_, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix
    real    ::  theta, beta_, dtk, g2, lamda
    real, dimension(      1-ng:nxyz(1)+ng ) :: soln, soln_, b, g1

    ix = nxyz(1)
    lamda = lamdaxyz(1)
    do i=1, ix
        g2 = lamda * (soln(i-1) -2*soln(i) + soln(i+1)) &
            - dtk * soln(i) * ( soln(i) - 1.0 ) * ( soln(i) - beta_ )
        b(i) = - ( soln(i) - soln_(i) - theta*g2 - (1-theta)*g1(i) )
    end do
end subroutine rhs_ac_1d

subroutine rhs_g1_ac_1d(nxyz, lamdaxyz, ng, soln, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix
    real    ::  theta, beta_, dtk, lamda
    real, dimension(      1-ng:nxyz(1)+ng ) :: soln, g1

    ix = nxyz(1)
    lamda = lamdaxyz(1)
    do i=1, ix
        g1(i) = lamda * (soln(i-1) -2*soln(i) + soln(i+1)) &
            - dtk * soln(i) * ( soln(i) - 1.0 ) * ( soln(i) - beta_ )
    end do
end subroutine rhs_g1_ac_1d

subroutine bc_pfm_ac_1d_l(nxyz, ng, soln)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, nx
    real, dimension(1-ng:nxyz(1)+ng ) :: soln

    nx = nxyz(1)
    soln(1-ng:0) = 2.0 - soln(1)
end subroutine bc_pfm_ac_1d_l

subroutine bc_pfm_ac_1d_r(nxyz, ng, soln)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, nx
    real, dimension(1-ng:nxyz(1)+ng ) :: soln

    nx = nxyz(1)
    soln(nx+1:nx+ng) = soln(nx)
end subroutine bc_pfm_ac_1d_r

!! 2D

!! setup the stencil struct matrix, A
subroutine stencil_ac_2d(nxyz, lamdaxyz, ng, A, soln, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, j, ix, jy
    real    ::  theta, beta_, dtk, lamdax, lamday
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: soln
    real, dimension(1:5,  1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    do j=1, jy
    do i=1, ix
        A(1,i,j) = -theta*lamdax
        A(2,i,j) = -theta*lamdax
        A(3,i,j) = -theta*lamday
        A(4,i,j) = -theta*lamday
        A(5,i,j) = 1 + 2*theta*(lamdax + lamday) + theta*dtk * (  &
              (soln(i,j)-1.0) * ( soln(i,j) - beta_ )  &
            + (soln(i,j)    ) * ( soln(i,j) - beta_  )  &
            + (soln(i,j)    ) * ( soln(i,j) - 1.0    )  )
    end do
    end do
end subroutine stencil_ac_2d

subroutine rhs_ac_2d(nxyz, lamdaxyz, ng, b, soln, soln_, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy
    real    ::  theta, beta_, dtk, g2, lamdax, lamday
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: soln, soln_, b, g1

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    do j=1, jy
    do i=1, ix
        g2 = lamdax * ( soln(i-1,j  ) -2*soln(i,j) + soln(i+1,j  ) ) &
           + lamday * ( soln(i,  j-1) -2*soln(i,j) + soln(i,  j+1) ) &
           - dtk * soln(i,j) * ( soln(i,j) - 1.0 ) * ( soln(i,j) - beta_ )
        b(i,j) = - ( soln(i,j) - soln_(i,j) - theta*g2 - (1-theta)*g1(i,j) )
    end do
    end do
end subroutine rhs_ac_2d

subroutine rhs_g1_ac_2d(nxyz, lamdaxyz, ng, soln, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy
    real    ::  theta, beta_, dtk, lamdax, lamday
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: soln, g1

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    do j=1, jy
    do i=1, ix
        g1(i,j) = lamdax * ( soln(i-1, j  ) -2*soln(i,j) + soln(i+1,j  ) ) &
                + lamday * ( soln(i,   j-1) -2*soln(i,j) + soln(i,  j+1) ) &
                - dtk * soln(i,j) * ( soln(i,j) - 1.0 ) * ( soln(i,j) - beta_ )
    end do
    end do
end subroutine rhs_g1_ac_2d

!! the example of customized BC
subroutine bc_pfm_ac_2d_l(sxyz, ng, p)
implicit none
    integer :: ng, sy
    integer, dimension(3) :: sxyz
    real, dimension(1-ng:sxyz(1)-ng, 1:sxyz(2)) :: p

    sy = sxyz(2)
    p(1-ng:0, 1:sy) = 2.0 - p(1:1, 1:sy)
end subroutine bc_pfm_ac_2d_l

subroutine bc_pfm_ac_2d_r(sxyz, ng,  p)
implicit none
    integer :: ng, nx, sy
    integer, dimension(3) :: sxyz
    real, dimension(1-ng:sxyz(1)-ng, 1:sxyz(2)) :: p

    nx = sxyz(1) - 2*ng
    sy = sxyz(2)
    p(nx+1:nx+ng, 1:sy) = p(nx:nx, 1:sy)
end subroutine bc_pfm_ac_2d_r

!! 2D front
subroutine bc_pfm_ac_2d_f(sxyz, ng, p)
implicit none
    integer :: ng, sx
    integer, dimension(3) :: sxyz
    real, dimension(1:sxyz(1), 1-ng:sxyz(2)-ng) :: p

    sx = sxyz(1)
    p(1:sx , 1-ng:0) = p(1:sx , 1:1)
end subroutine bc_pfm_ac_2d_f

!! 2D back
subroutine bc_pfm_ac_2d_b(sxyz, ng, p)
implicit none
    integer :: ng, sx, ny
    integer, dimension(3) :: sxyz
    real, dimension(1:sxyz(1), 1-ng:sxyz(2)-ng) :: p

    sx = sxyz(1)
    ny = sxyz(2) - 2*ng
    p(1:sx , ny+1:ny+ng) = p(1:sx, ny:ny)
end subroutine bc_pfm_ac_2d_b

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! 3D
!!
!! setup the stencil struct matrix, A
subroutine stencil_ac_3d(nxyz, lamdaxyz, ng, A, soln, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, j, k, ix, jy, kz
    real    ::  theta, beta_, dtk, lamdax, lamday, lamdaz
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln
    real, dimension(1:7,  1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)
!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz, lamdax, lamday, lamdaz, theta, dtk, beta_)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        A(1,i,j,k) = -theta*lamdax
        A(2,i,j,k) = -theta*lamdax
        A(3,i,j,k) = -theta*lamday
        A(4,i,j,k) = -theta*lamday
        A(5,i,j,k) = -theta*lamdaz
        A(6,i,j,k) = -theta*lamdaz
        A(7,i,j,k) = 1 + 2*theta*(lamdax + lamday + lamdaz) + theta*dtk * (  &
              (soln(i,j,k)-1.0) * ( soln(i,j,k) - beta_ )  &
            + (soln(i,j,k)    ) * ( soln(i,j,k) - beta_  )  &
            + (soln(i,j,k)    ) * ( soln(i,j,k) - 1.0    )  )
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine stencil_ac_3d

subroutine rhs_ac_3d(nxyz, lamdaxyz, ng, b, soln, soln_, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy, k, kz
    real    ::  theta, beta_, dtk, g2, lamdax, lamday, lamdaz
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln, soln_, b, g1

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)
!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz, lamdax, lamday, lamdaz, theta, dtk, beta_)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        g2 = lamdax * ( soln(i-1, j,   k  ) - 2*soln(i,j,k) + soln(i+1, j,   k  ) ) &
           + lamday * ( soln(i,   j-1, k  ) - 2*soln(i,j,k) + soln(i,   j+1, k  ) ) &
           + lamdaz * ( soln(i,   j,   k-1) - 2*soln(i,j,k) + soln(i,   j,   k+1) ) &
           - dtk * soln(i,j,k) * ( soln(i,j,k) - 1.0 ) * ( soln(i,j,k) - beta_ )
        b(i,j,k) = - ( soln(i,j,k) - soln_(i,j,k) - theta*g2 - (1-theta)*g1(i,j,k) )
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine rhs_ac_3d

subroutine rhs_g1_ac_3d(nxyz, lamdaxyz, ng, soln, g1, theta, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy, k, kz
    real    ::  theta, beta_, dtk, lamdax, lamday, lamdaz
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln, g1

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)
!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz, lamdax, lamday, lamdaz, theta, dtk, beta_)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        g1(i,j,k) = lamdax * ( soln(i-1, j,   k  ) - 2*soln(i,j,k) + soln(i+1, j,   k  ) ) &
                  + lamday * ( soln(i,   j-1, k  ) - 2*soln(i,j,k) + soln(i,   j+1, k  ) ) &
                  + lamdaz * ( soln(i,   j,   k-1) - 2*soln(i,j,k) + soln(i,   j,   k+1) ) &
                  - dtk * soln(i,j,k) * ( soln(i,j,k) - 1.0 ) * ( soln(i,j,k) - beta_ )
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine rhs_g1_ac_3d

!!
!! Frist order forward Euler method
!!
subroutine euler_rhs_ac_1d(nxyz, lamdaxyz, ng, b, soln, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix
    real    ::  dtk, beta_, ss, lamdax
    real, dimension( 1-ng:nxyz(1)+ng ) :: soln, b

    ix = nxyz(1)
    lamdax = lamdaxyz(1)
    do i=1, ix
        ss = lamdax * ( soln(i+1) - 2*soln(i) + soln(i-1) )
        b(i) = ss - dtk * soln(i) * ( soln(i) - 1.0 ) * ( soln(i) - beta_ )
    end do

end subroutine euler_rhs_ac_1d

subroutine euler_rhs_ac_2d(nxyz, lamdaxyz, ng, b, soln, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy
    real    ::  dtk, beta_, ss, lamdax, lamday
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng) :: soln, b

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)

    do j=1, jy
    do i=1, ix

        ss = lamdax * ( soln(i-1, j   ) - 2*soln(i,j) + soln(i+1, j  ) ) &
           + lamday * ( soln(i,   j-1 ) - 2*soln(i,j) + soln(i,   j+1) )
        b(i,j) = ss - dtk * soln(i,j) * ( soln(i,j) - 1.0 ) * ( soln(i,j) - beta_ )

    end do
    end do

end subroutine euler_rhs_ac_2d

subroutine euler_rhs_ac_3d(nxyz, lamdaxyz, ng, b, soln, dtk, beta_)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy, k, kz
    real    ::  dtk, beta_, ss, lamdax, lamday, lamdaz
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln, b

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)

!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz, lamdax, lamday, lamdaz, dtk, beta_)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        ss = lamdax * ( soln(i-1, j,   k  ) - 2*soln(i,j,k) + soln(i+1, j,   k  ) ) &
           + lamday * ( soln(i,   j-1, k  ) - 2*soln(i,j,k) + soln(i,   j+1, k  ) ) &
           + lamdaz * ( soln(i,   j,   k-1) - 2*soln(i,j,k) + soln(i,   j,   k+1) )
        b(i,j,k) = ss - dtk * soln(i,j,k) * ( soln(i,j,k) - 1.0 ) * ( soln(i,j,k) - beta_ )

    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine euler_rhs_ac_3d


      FUNCTION IFIB(N)
      IF (N.EQ.0) THEN
        ITEMP0=0
      ELSE IF (N.EQ.1) THEN
        ITEMP0=1
      ELSE IF (N.GT.1) THEN
        ITEMP1=0
        ITEMP0=1
        DO 1 I=2,N
          ITEMP2=ITEMP1
          ITEMP1=ITEMP0
          ITEMP0=ITEMP1+ITEMP2
    1   CONTINUE
      ELSE
        ITEMP1=1
        ITEMP0=0
        DO 2 I=-1,N,-1
          ITEMP2=ITEMP1
          ITEMP1=ITEMP0
          ITEMP0=ITEMP2-ITEMP1
    2   CONTINUE
      END IF
      IFIB=ITEMP0
      END