c
c GCVSPL.FOR, 1986-05-12
c (C) COPYRIGHT 1985, 1986: H.J. Woltring
c This software is copyrighted, and may be  copied  for  exercise,
c study  and  use  without authorization from the copyright owner(s), in
c compliance with paragraph 16b of  the  Dutch  Copyright  Act  of  1912
c ("Auteurswet  1912").  Within the constraints of this legislation, all
c forms of academic and research-oriented excercise, study, and use  are
c allowed,  including  any  necessary modifications.  Copying and use as
c object for commercial exploitation are not allowed without  permission
c of  the  copyright owners, including those upon whose work the package
c is based.
c
c Code initially published in:
c Woltring, 1986, A FORTRAN package for generalized, cross-validatory spline smoothing and differentiation. Adv. Eng. Softw. 8:104-113.
c ####
c Note of Charles Le Losq:
c Code available on www.netlib.org, other versions are available on https://isbweb.org/software/sigproc.html
c This is a Fortran 77 version downloaded on https://isbweb.org/software/sigproc.html
c***********************************************************************
c
c SUBROUTINE GCVSPL (REAL*8)
c
c Purpose:
c *******
c
c       Natural B-spline data smoothing subroutine, using the Generali-
c       zed Cross-Validation and Mean-Squared Prediction Error Criteria
c       of Craven & Wahba (1979). Alternatively, the amount of smoothing
c       can be given explicitly, or it can be based on the effective
c       number of degrees of freedom in the smoothing process as defined
c       by Wahba (1980). The model assumes uncorrelated, additive noise
c       and essentially smooth, underlying functions. The noise may be
c       non-stationary, and the independent co-ordinates may be spaced
c       non-equidistantly. Multiple datasets, with common independent
c       variables and weight factors are accomodated.
c
c
c Calling convention:
c ******************
c
c       CALL GCVSPL ( X, Y, NY, WX, WY, M, N, K, MD, VAL, C, NC, WK, IER
c )
c
c Meaning of parameters:
c *********************
c
c       X(N)    ( I )   Independent variables: strictly increasing knot
c                       sequence, with X(I-1).lt.X(I), I=2,...,N.
c       Y(NY,K) ( I )   Input data to be smoothed (or interpolated).
c       NY      ( I )   First dimension of array Y(NY,K), with NY.ge.N.
c       WX(N)   ( I )   Weight factor array; WX(I) corresponds with
c                       the relative inverse variance of point Y(I,*).
c                       If no relative weighting information is
c                       available, the WX(I) should be set to ONE.
c                       All WX(I).gt.ZERO, I=1,...,N.
c       WY(K)   ( I )   Weight factor array; WY(J) corresponds with
c                       the relative inverse variance of point Y(*,J).
c                       If no relative weighting information is
c                       available, the WY(J) should be set to ONE.
c                       All WY(J).gt.ZERO, J=1,...,K.
c                       NB: The effective weight for point Y(I,J) is
c                       equal to WX(I)*WY(J).
c       M       ( I )   Half order of the required B-splines (spline
c                       degree 2*M-1), with M.gt.0. The values M =
c                       1,2,3,4 correspond to linear, cubic, quintic,
c                       and heptic splines, respectively.
c       N       ( I )   Number of observations per dataset, with N.ge.2*
cM.
c       K       ( I )   Number of datasets, with K.ge.1.
c       MD      ( I )   Optimization mode switch:
c                       |MD| = 1: Prior given value for p in VAL
c                                 (VAL.ge.ZERO). This is the fastest
c                                 use of GCVSPL, since no iteration
c                                 is performed in p.
c                       |MD| = 2: Generalized cross validation.
c                       |MD| = 3: True predicted mean-squared error,
c                                 with prior given variance in VAL.
c                       |MD| = 4: Prior given number of degrees of
c                                 freedom in VAL (ZERO.le.VAL.le.N-M).
c                        MD  < 0: It is assumed that the contents of
c                                 X, W, M, N, and WK have not been
c                                 modified since the previous invoca-
c                                 tion of GCVSPL. If MD < -1, WK(4)
c                                 is used as an initial estimate for
c                                 the smoothing parameter p.  At the
c                                 first call to GCVSPL, MD must be > 0.
c                       Other values for |MD|, and inappropriate values
c                       for VAL will result in an error condition, or
c                       cause a default value for VAL to be selected.
c                       After return from MD.ne.1, the same number of
c                       degrees of freedom can be obtained, for identica
cl
c                       weight factors and knot positions, by selecting
c                       |MD|=1, and by copying the value of p from WK(4)
c                       into VAL. In this way, no iterative optimization
c                       is required when processing other data in Y.
c       VAL     ( I )   Mode value, as described above under MD.
c       C(NC,K) ( O )   Spline coefficients, to be used in conjunction
c                       with function SPLDER. NB: the dimensions of C
c                       in GCVSPL and in SPLDER are different! In SPLDER
c,
c                       only a single column of C(N,K) is needed, and th
ce
c                       proper column C(1,J), with J=1...K should be use
cd
c                       when calling SPLDER.
c       NC       ( I )  First dimension of array C(NC,K), NC.ge.N.
c       WK(IWK) (I/W/O) Work vector, with length IWK.ge.6*(N*M+1)+N.
c                       On normal exit, the first 6 values of WK are
c                       assigned as follows:
c
c                       WK(1) = Generalized Cross Validation value
c                       WK(2) = Mean Squared Residual.
c                       WK(3) = Estimate of the number of degrees of
c                               freedom of the residual sum of squares
c                               per dataset, with 0.lt.WK(3).lt.N-M.
c                       WK(4) = Smoothing parameter p, multiplicative
c                               with the splines' derivative constraint.
c                       WK(5) = Estimate of the true mean squared error
c                               (different formula for |MD| = 3).
c                       WK(6) = Gauss-Markov error variance.
c
c                       If WK(4) -->  0 , WK(3) -->  0 , and an inter-
c                       polating spline is fitted to the data (p --> 0).
c                       A very small value > 0 is used for p, in order
c                       to avoid division by zero in the GCV function.
c
c                       If WK(4) --> inf, WK(3) --> N-M, and a least-
c                       squares polynomial of order M (degree M-1) is
c                       fitted to the data (p --> inf). For numerical
c                       reasons, a very high value is used for p.
c
c                       Upon return, the contents of WK can be used for
c                       covariance propagation in terms of the matrices
c                       B and WE: see the source listings. The variance
c                       estimate for dataset J follows as WK(6)/WY(J).
c
c       IER     ( O )   Error parameter:
c
c                       IER = 0:        Normal exit
c                       IER = 1:        M.le.0 .or. N.lt.2*M
c                       IER = 2:        Knot sequence is not strictly
c                                       increasing, or some weight
c                                       factor is not positive.
c                       IER = 3:        Wrong mode  parameter or value.
c
c Remarks:
c *******
c
c       (1) GCVSPL calculates a natural spline of order 2*M (degree
c       2*M-1) which smoothes or interpolates a given set of data
c       points, using statistical considerations to determine the
c       amount of smoothing required (Craven & Wahba, 1979). If the
c       error variance is a priori known, it should be supplied to
c       the routine in VAL, for |MD|=3. The degree of smoothing is
c       then determined to minimize an unbiased estimate of the true
c       mean squared error. On the other hand, if the error variance
c       is not known, one may select |MD|=2. The routine then deter-
c       mines the degree of smoothing to minimize the generalized
c       cross validation function. This is asymptotically the same
c       as minimizing the true predicted mean squared error (Craven &
c       Wahba, 1979). If the estimates from |MD|=2 or 3 do not appear
c       suitable to the user (as apparent from the smoothness of the
c       M-th derivative or from the effective number of degrees of
c       freedom returned in WK(3) ), the user may select an other
c       value for the noise variance if |MD|=3, or a reasonably large
c       number of degrees of freedom if |MD|=4. If |MD|=1, the proce-
c       dure is non-iterative, and returns a spline for the given
c       value of the smoothing parameter p as entered in VAL.
c
c       (2) The number of arithmetic operations and the amount of
c       storage required are both proportional to N, so very large
c       datasets may be accomodated. The data points do not have
c       to be equidistant in the independant variable X or uniformly
c       weighted in the dependant variable Y. However, the data
c       points in X must be strictly increasing. Multiple dataset
c       processing (K.gt.1) is numerically more efficient dan
c       separate processing of the individual datasets (K.eq.1).
c
c       (3) If |MD|=3 (a priori known noise variance), any value of
c       N.ge.2*M is acceptable. However, it is advisable for N-2*M
c       be rather large (at least 20) if |MD|=2 (GCV).
c
c       (4) For |MD| > 1, GCVSPL tries to iteratively minimize the
c       selected criterion function. This minimum is unique for |MD|
c       = 4, but not necessarily for |MD| = 2 or 3. Consequently,
c       local optima rather that the global optimum might be found,
c       and some actual findings suggest that local optima might
c       yield more meaningful results than the global optimum if N
c       is small. Therefore, the user has some control over the
c       search procedure. If MD > 1, the iterative search starts
c       from a value which yields a number of degrees of freedom
c       which is approximately equal to N/2, until the first (local)
c       minimum is found via a golden section search procedure
c       (Utreras, 1980). If MD < -1, the value for p contained in
c       WK(4) is used instead. Thus, if MD = 2 or 3 yield too noisy
c       an estimate, the user might try |MD| = 1 or 4, for suitably
c       selected values for p or for the number of degrees of
c       freedom, and then run GCVSPL with MD = -2 or -3. The con-
c       tents of N, M, K, X, WX, WY, and WK are assumed unchanged
c       since the last call to GCVSPL if MD < 0.
c
c       (5) GCVSPL calculates the spline coefficient array C(N,K);
c       this array can be used to calculate the spline function
c       value and any of its derivatives up to the degree 2*M-1
c       at any argument T within the knot range, using subrou-
c       tines SPLDER and SEARCH, and the knot array X(N). Since
c       the splines are constrained at their Mth derivative, only
c       the lower spline derivatives will tend to be reliable
c       estimates of the underlying, true signal derivatives.
c
c       (6) GCVSPL combines elements of subroutine CRVO5 by Utre-
c       ras (1980), subroutine SMOOTH by Lyche et al. (1983), and
c       subroutine CUBGCV by Hutchinson (1985). The trace of the
c       influence matrix is assessed in a similar way as described
c       by Hutchinson & de Hoog (1985). The major difference is
c       that the present approach utilizes non-symmetrical B-spline
c       design matrices as described by Lyche et al. (1983); there-
c       fore, the original algorithm by Erisman & Tinney (1975) has
c       been used, rather than the symmetrical version adopted by
c       Hutchinson & de Hoog.
c
c References:
c **********
c
c       P. Craven & G. Wahba (1979), Smoothing noisy data with
c       spline functions. Numerische Mathematik 31, 377-403.
c
c       A.M. Erisman & W.F. Tinney (1975), On computing certain
c       elements of the inverse of a sparse matrix. Communications
c       of the ACM 18(3), 177-179.
c
c       M.F. Hutchinson & F.R. de Hoog (1985), Smoothing noisy data
c       with spline functions. Numerische Mathematik 47(1), 99-106.
c
c       M.F. Hutchinson (1985), Subroutine CUBGCV. CSIRO Division of
c       Mathematics and Statistics, P.O. Box 1965, Canberra, ACT 2601,
c       Australia.
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori (1983), Fortran
c       subroutines for computing smoothing and interpolating natural
c       splines. Advances in Engineering Software 5(1), 2-5.
c
c       F. Utreras (1980), Un paquete de programas para ajustar curvas
c       mediante funciones spline. Informe Tecnico MA-80-B-209, Depar-
c       tamento de Matematicas, Faculdad de Ciencias Fisicas y Matema-
c       ticas, Universidad de Chile, Santiago.
c
c       Wahba, G. (1980). Numerical and statistical methods for mildly,
c       moderately and severely ill-posed problems with noisy data.
c       Technical report nr. 595 (February 1980). Department of Statis-
c       tics, University of Madison (WI), U.S.A.
c
c Subprograms required:
c ********************
c
c       BASIS, PREP, SPLC, BANDET, BANSOL, TRINV
c
c***********************************************************************
c
c
      subroutine gcvspl(x, y, ny, wx, wy, m, n, k, md, val, c, nc, wk,
     &ier)
      implicit double precision (o-z, a-h)
      parameter (ratio = 2d0, tau = 1.618033983d0, ibwe = 7, zero = 0d0
     &, half = 5d-1, one = 1d0, tol = 1d-6, eps = 1d-15, epsinv = one /
     &eps)
      dimension x(n), y(ny, k), wx(n), wy(k), c(nc, k), wk(n + (6 * ((n
     & * m) + 1)))
      save el, nm1, m2
c
c***  Parameter check and work array initialization
c
c***  Check on mode parameter
      data m2 / 0 /
      data nm1 / 0 /
      data el / 0d0 /
      ier = 0
      if (((((iabs(md) .gt. 4) .or. (md .eq. 0)) .or. ((iabs(md) .eq. 1)
     & .and. (val .lt. zero))) .or. ((iabs(md) .eq. 3) .and. (val .lt.
     &zero))) .or. ((iabs(md) .eq. 4) .and. ((val .lt. zero) .or. (val
     & .gt. (n - m))))) then
cWrong mode value
      ier = 3
      return
c***  Check on M and N
      end if
      if (md .gt. 0) then
      m2 = 2 * m
      nm1 = n - 1
      else
      if ((m2 .ne. (2 * m)) .or. (nm1 .ne. (n - 1))) then
cM or N modified since previous call
      ier = 3
      return
      end if
      end if
      if ((m .le. 0) .or. (n .lt. m2)) then
cM or N invalid
      ier = 1
      return
c***  Check on knot sequence and weights
      end if
      if (wx(1) .le. zero) ier = 2
      do 10 i = 2, n
      if ((wx(i) .le. zero) .or. (x(i - 1) .ge. x(i))) ier = 2
      if (ier .ne. 0) return
   10 continue
      do 15 j = 1, k
      if (wy(j) .le. zero) ier = 2
      if (ier .ne. 0) return
c
c***  Work array parameters (address information for covariance
c***  propagation by means of the matrices STAT, B, and WE). NB:
c***  BWE cannot be used since it is modified by function TRINV.
c
   15 continue
      nm2p1 = n * (m2 + 1)
c     ISTAT = 1            !Statistics array STAT(6)
c     IBWE  = ISTAT + 6      !Smoothing matrix BWE( -M:M  ,N)
      nm2m1 = n * (m2 - 1)
cDesign matrix    B  (1-M:M-1,N)
      ib = ibwe + nm2p1
c     IWK   = IWE   + NM2P1      !Total work array length N + 6*(N*M+1)
c
c***  Compute the design matrices B and WE, the ratio
c***  of their L1-norms, and check for iterative mode.
c
cDesign matrix    WE ( -M:M  ,N)
      iwe = ib + nm2m1
      if (md .gt. 0) then
      call basis(m, n, x, wk(ib), r1, wk(ibwe))
      call prep(m, n, x, wx, wk(iwe), el)
cL1-norms ratio (SAVEd upon RETURN)
      el = el / r1
      end if
c***     Prior given value for p
      if (iabs(md) .ne. 1) goto 20
      r1 = val
c
c***  Iterate to minimize the GCV function (|MD|=2),
c***  the MSE function (|MD|=3), or to obtain the prior
c***  given number of degrees of freedom (|MD|=4).
c
      goto 100
   20 if (md .lt. (-1)) then
cUser-determined starting value
      r1 = wk(4)
      else
cDefault (DOF ~ 0.5)
      r1 = one / el
      end if
      r2 = r1 * ratio
      gf2 = splc(m,n,k,y,ny,wx,wy,md,val,r2,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
   40 gf1 = splc(m,n,k,y,ny,wx,wy,md,val,r1,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      if (gf1 .gt. gf2) goto 50
cInterpolation
      if (wk(4) .le. zero) goto 100
      r2 = r1
      gf2 = gf1
      r1 = r1 / ratio
      goto 40
   50 r3 = r2 * ratio
   60 gf3 = splc(m,n,k,y,ny,wx,wy,md,val,r3,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      if (gf3 .gt. gf2) goto 70
cLeast-squares polynomial
      if (wk(4) .ge. epsinv) goto 100
      r2 = r3
      gf2 = gf3
      r3 = r3 * ratio
      goto 60
   70 r2 = r3
      gf2 = gf3
      alpha = (r2 - r1) / tau
      r4 = r1 + alpha
      r3 = r2 - alpha
      gf3 = splc(m,n,k,y,ny,wx,wy,md,val,r3,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      gf4 = splc(m,n,k,y,ny,wx,wy,md,val,r4,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
   80 if (gf3 .le. gf4) then
      r2 = r4
      gf2 = gf4
      err = (r2 - r1) / (r1 + r2)
      if ((((err * err) + one) .eq. one) .or. (err .le. tol)) goto 90
      r4 = r3
      gf4 = gf3
      alpha = alpha / tau
      r3 = r2 - alpha
      gf3 = splc(m,n,k,y,ny,wx,wy,md,val,r3,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      else
      r1 = r3
      gf1 = gf3
      err = (r2 - r1) / (r1 + r2)
      if ((((err * err) + one) .eq. one) .or. (err .le. tol)) goto 90
      r3 = r4
      gf3 = gf4
      alpha = alpha / tau
      r4 = r1 + alpha
      gf4 = splc(m,n,k,y,ny,wx,wy,md,val,r4,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      end if
      goto 80
c
c***  Calculate final spline coefficients
c
   90 r1 = half * (r1 + r2)
c
c***  Ready
c
  100 gf1 = splc(m,n,k,y,ny,wx,wy,md,val,r1,eps,c,nc,wk,wk(ib),wk(iwe),
     &el,wk(ibwe))
      return
c BASIS.FOR, 1985-06-03
c
c***********************************************************************
c
c SUBROUTINE BASIS (REAL*8)
c
c Purpose:
c *******
c
c       Subroutine to assess a B-spline tableau, stored in vectorized
c       form.
c
c Calling convention:
c ******************
c
c       CALL BASIS ( M, N, X, B, BL, Q )
c
c Meaning of parameters:
c *********************
c
c       M               ( I )   Half order of the spline (degree 2*M-1),
c                               M > 0.
c       N               ( I )   Number of knots, N >= 2*M.
c       X(N)            ( I )   Knot sequence, X(I-1) < X(I), I=2,N.
c       B(1-M:M-1,N)    ( O )   Output tableau. Element B(J,I) of array
c                               B corresponds with element b(i,i+j) of
c                               the tableau matrix B.
c       BL              ( O )   L1-norm of B.
c       Q(1-M:M)        ( W )   Internal work array.
c
c Remark:
c ******
c
c       This subroutine is an adaptation of subroutine BASIS from the
c       paper by Lyche et al. (1983). No checking is performed on the
c       validity of M and N. If the knot sequence is not strictly in-
c       creasing, division by zero may occur.
c
c Reference:
c *********
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      subroutine basis(m, n, x, b, bl, q)
      implicit double precision (o-z, a-h)
      parameter (zero = 0d0, one = 1d0)
c
      dimension x(n), b(1 - m:m - 1, n), q(1 - m:m)
c***         Linear spline
      if (m .eq. 1) then
      do 3 i = 1, n
      b(0,i) = one
    3 continue
      bl = one
      return
c
c***  General splines
c
      end if
      mm1 = m - 1
      mp1 = m + 1
      m2 = 2 * m
c***     1st row
      do 15 l = 1, n
      do 5 j = - mm1, m
      q(j) = zero
    5 continue
      q(mm1) = one
c***     Successive rows
      if ((l .ne. 1) .and. (l .ne. n)) q(mm1) = one / (x(l + 1) - x(l -
     &1))
      arg = x(l)
      do 13 i = 3, m2
      ir = mp1 - i
      v = q(ir)
c***               Left-hand B-splines
      if (l .lt. i) then
      do 6 j = l + 1, i
      u = v
      v = q(ir + 1)
      q(ir) = u + ((x(j) - arg) * v)
      ir = ir + 1
    6 continue
      end if
      j1 = max0((l - i) + 1,1)
      j2 = min0(l - 1,n - i)
c***               Ordinary B-splines
      if (j1 .le. j2) then
      if (i .lt. m2) then
      do 8 j = j1, j2
      y = x(i + j)
      u = v
      v = q(ir + 1)
      q(ir) = u + (((v - u) * (y - arg)) / (y - x(j)))
      ir = ir + 1
    8 continue
      else
      do 10 j = j1, j2
      u = v
      v = q(ir + 1)
      q(ir) = ((arg - x(j)) * u) + ((x(i + j) - arg) * v)
      ir = ir + 1
   10 continue
      end if
      end if
      nmip1 = (n - i) + 1
c***           Right-hand B-splines
      if (nmip1 .lt. l) then
      do 12 j = nmip1, l - 1
      u = v
      v = q(ir + 1)
      q(ir) = ((arg - x(j)) * u) + v
      ir = ir + 1
   12 continue
      end if
   13 continue
      do 14 j = - mm1, mm1
      b(j,l) = q(j)
   14 continue
c
c***  Zero unused parts of B
c
   15 continue
      do 17 i = 1, mm1
      do 16 k = i, mm1
      b(- k,i) = zero
      b(k,(n + 1) - i) = zero
   16 continue
c
c***  Assess L1-norm of B
c
   17 continue
      bl = 0d0
      do 19 i = 1, n
      do 18 k = - mm1, mm1
      bl = bl + abs(b(k,i))
   18 continue
   19 continue
c
c***  Ready
c
      bl = bl / n
      return
c PREP.FOR, 1985-07-04
c
c***********************************************************************
c
c SUBROUTINE PREP (REAL*8)
c
c Purpose:
c *******
c
c       To compute the matrix WE of weighted divided difference coeffi-
c       cients needed to set up a linear system of equations for sol-
c       ving B-spline smoothing problems, and its L1-norm EL. The matrix
c       WE is stored in vectorized form.
c
c Calling convention:
c ******************
c
c       CALL PREP ( M, N, X, W, WE, EL )
c
c Meaning of parameters:
c *********************
c
c       M               ( I )   Half order of the B-spline (degree
c                               2*M-1), with M > 0.
c       N               ( I )   Number of knots, with N >= 2*M.
c       X(N)            ( I )   Strictly increasing knot array, with
c                               X(I-1) < X(I), I=2,N.
c       W(N)            ( I )   Weight matrix (diagonal), with
c                               W(I).gt.0.0, I=1,N.
c       WE(-M:M,N)      ( O )   Array containing the weighted divided
c                               difference terms in vectorized format.
c                               Element WE(J,I) of array E corresponds
c                               with element e(i,i+j) of the matrix
c                               W**-1 * E.
c       EL              ( O )   L1-norm of WE.
c
c Remark:
c ******
c
c       This subroutine is an adaptation of subroutine PREP from the pap
cer
c       by Lyche et al. (1983). No checking is performed on the validity
c       of M and N. Division by zero may occur if the knot sequence is
c       not strictly increasing.
c
c Reference:
c *********
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      subroutine prep(m, n, x, w, we, el)
      implicit double precision (o-z, a-h)
      parameter (zero = 0d0, one = 1d0)
c
c***  Calculate the factor F1
c
cWE(-M:M,N)
      dimension x(n), w(n), we(((2 * m) + 1) * n)
      m2 = 2 * m
      mp1 = m + 1
      m2m1 = m2 - 1
      m2p1 = m2 + 1
      nm = n - m
      f1 = - one
      if (m .ne. 1) then
      do 5 i = 2, m
      f1 = - (f1 * i)
    5 continue
      do 6 i = mp1, m2m1
      f1 = f1 * i
    6 continue
c
c***  Columnwise evaluation of the unweighted design matrix E
c
      end if
      i1 = 1
      i2 = m
      jm = mp1
      do 17 j = 1, n
      inc = m2p1
      if (j .gt. nm) then
      f1 = - f1
      f = f1
      else
      if (j .lt. mp1) then
      inc = 1
      f = f1
      else
      f = f1 * (x(j + m) - x(j - m))
      end if
      end if
      if (j .gt. mp1) i1 = i1 + 1
      if (i2 .lt. n) i2 = i2 + 1
c***     Loop for divided difference coefficients
      jj = jm
      ff = f
      y = x(i1)
      i1p1 = i1 + 1
      do 11 i = i1p1, i2
      ff = ff / (y - x(i))
   11 continue
      we(jj) = ff
      jj = jj + m2
      i2m1 = i2 - 1
      if (i1p1 .le. i2m1) then
      do 14 l = i1p1, i2m1
      ff = f
      y = x(l)
      do 12 i = i1, l - 1
      ff = ff / (y - x(i))
   12 continue
      do 13 i = l + 1, i2
      ff = ff / (y - x(i))
   13 continue
      we(jj) = ff
      jj = jj + m2
   14 continue
      end if
      ff = f
      y = x(i2)
      do 16 i = i1, i2m1
      ff = ff / (y - x(i))
   16 continue
      we(jj) = ff
      jj = jj + m2
      jm = jm + inc
c
c***  Zero the upper left and lower right corners of E
c
   17 continue
      kl = 1
      n2m = (m2p1 * n) + 1
      do 19 i = 1, m
      ku = (kl + m) - i
      do 18 k = kl, ku
      we(k) = zero
      we(n2m - k) = zero
   18 continue
      kl = kl + m2p1
c
c***  Weighted matrix WE = W**-1 * E and its L1-norm
c
   19 continue
   20 jj = 0
      el = 0d0
      do 22 i = 1, n
      wi = w(i)
      do 21 j = 1, m2p1
      jj = jj + 1
      we(jj) = we(jj) / wi
      el = el + abs(we(jj))
   21 continue
   22 continue
c
c***  Ready
c
      el = el / n
      return
c SPLC.FOR, 1985-12-12
c
c Author: H.J. Woltring
c
c Organizations: University of Nijmegen, and
c                Philips Medical Systems, Eindhoven
c                (The Netherlands)
c
c***********************************************************************
c
c FUNCTION SPLC (REAL*8)
c
c Purpose:
c *******
c
c       To assess the coefficients of a B-spline and various statistical
c       parameters, for a given value of the regularization parameter p.
c
c Calling convention:
c ******************
c
c       FV = SPLC ( M, N, K, Y, NY, WX, WY, MODE, VAL, P, EPS, C, NC,
c       1           STAT, B, WE, EL, BWE)
c
c Meaning of parameters:
c *********************
c
c       SPLC            ( O )   GCV function value if |MODE|.eq.2,
c                               MSE value if |MODE|.eq.3, and absolute
c                               difference with the prior given number o
cf
c                               degrees of freedom if |MODE|.eq.4.
c       M               ( I )   Half order of the B-spline (degree 2*M-1
c),
c                               with M > 0.
c       N               ( I )   Number of observations, with N >= 2*M.
c       K               ( I )   Number of datasets, with K >= 1.
c       Y(NY,K)         ( I )   Observed measurements.
c       NY              ( I )   First dimension of Y(NY,K), with NY.ge.N
c.
c       WX(N)           ( I )   Weight factors, corresponding to the
c                               relative inverse variance of each measur
ce-
c                               ment, with WX(I) > 0.0.
c       WY(K)           ( I )   Weight factors, corresponding to the
c                               relative inverse variance of each datase
ct,
c                               with WY(J) > 0.0.
c       MODE            ( I )   Mode switch, as described in GCVSPL.
c       VAL             ( I )   Prior variance if |MODE|.eq.3, and
c                               prior number of degrees of freedom if
c                               |MODE|.eq.4. For other values of MODE,
c                               VAL is not used.
c       P               ( I )   Smoothing parameter, with P >= 0.0. If
c                               P.eq.0.0, an interpolating spline is
c                               calculated.
c       EPS             ( I )   Relative rounding tolerance*10.0. EPS is
c                               the smallest positive number such that
c                               EPS/10.0 + 1.0 .ne. 1.0.
c       C(NC,K)         ( O )   Calculated spline coefficient arrays. NB
c:
c                               the dimensions of in GCVSPL and in SPLDE
cR
c                               are different! In SPLDER, only a single
c                               column of C(N,K) is needed, and the prop
cer
c                               column C(1,J), with J=1...K, should be u
csed
c                               when calling SPLDER.
c       NC              ( I )   First dimension of C(NC,K), with NC.ge.N
c.
c       STAT(6)         ( O )   Statistics array. See the description in
c                               subroutine GCVSPL.
c       B (1-M:M-1,N)   ( I )   B-spline tableau as evaluated by subrout
cine
c                               BASIS.
c       WE( -M:M  ,N)   ( I )   Weighted B-spline tableau (W**-1 * E) as
c                               evaluated by subroutine PREP.
c       EL              ( I )   L1-norm of the matrix WE as evaluated by
c                               subroutine PREP.
c       BWE(-M:M,N)     ( O )   Central 2*M+1 bands of the inverted
c                               matrix ( B  +  p * W**-1 * E )**-1
c
c Remarks:
c *******
c
c       This subroutine combines elements of subroutine SPLC0 from the
c       paper by Lyche et al. (1983), and of subroutine SPFIT1 by
c       Hutchinson (1985).
c
c References:
c **********
c
c       M.F. Hutchinson (1985), Subroutine CUBGCV. CSIRO division of
c       Mathematics and Statistics, P.O. Box 1965, Canberra, ACT 2601,
c       Australia.
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      function splc(m, n, k, y, ny, wx, wy, mode, val, p, eps, c, nc,
     &stat, b, we, el, bwe)
      implicit double precision (o-z, a-h)
      parameter (zero = 0d0, one = 1d0, two = 2d0)
c
c***  Check on p-value
c
      dimension y(ny, k), wx(n), wy(k), c(nc, k), stat(6), b(1 - m:m - 1
     &, n), we(- m:m, n), bwe(- m:m, n)
      dp = p
      stat(4) = p
c***  Pseudo-interpolation if p is too small
      pel = p * el
      if (pel .lt. eps) then
      dp = eps / el
      stat(4) = zero
c***  Pseudo least-squares polynomial if p is too large
      end if
      if ((pel * eps) .gt. one) then
      dp = one / (el * eps)
      stat(4) = dp
c
c***  Calculate  BWE  =  B  +  p * W**-1 * E
c
      end if
      do 40 i = 1, n
      km = - min0(m,i - 1)
      kp = min0(m,n - i)
      do 30 l = km, kp
      if (iabs(l) .eq. m) then
      bwe(l,i) = dp * we(l,i)
      else
      bwe(l,i) = b(l,i) + (dp * we(l,i))
      end if
   30 continue
c
c***  Solve BWE * C = Y, and assess TRACE [ B * BWE**-1 ]
c
   40 continue
      call bandet(bwe, m, n)
      call bansol(bwe, y, ny, c, nc, m, n, k)
ctrace * p = res. d.o.
      stat(3) = trinv(we,bwe,m,n) * dp
c
c***  Compute mean-squared weighted residual
c
      trn = stat(3) / n
      esn = zero
      do 70 j = 1, k
      do 60 i = 1, n
      dt = - y(i,j)
      km = - min0(m - 1,i - 1)
      kp = min0(m - 1,n - i)
      do 50 l = km, kp
      dt = dt + (b(l,i) * c(i + l,j))
   50 continue
      esn = esn + (((dt * dt) * wx(i)) * wy(j))
   60 continue
   70 continue
c
c***  Calculate statistics and function value
c
      esn = esn / (n * k)
cEstimated variance
      stat(6) = esn / trn
cGCV function value
      stat(1) = stat(6) / trn
c     STAT(3) = trace [p*B * BWE**-1] !Estimated residuals' d.o.f.
c     STAT(4) = P                     !Normalized smoothing factor
cMean Squared Residual
      stat(2) = esn
c***     Unknown variance: GCV
      if (iabs(mode) .ne. 3) then
      stat(5) = stat(6) - esn
      if (iabs(mode) .eq. 1) splc = zero
      if (iabs(mode) .eq. 2) splc = stat(1)
      if (iabs(mode) .eq. 4) splc = dabs(stat(3) - val)
c***     Known variance: estimated mean squared error
      else
      stat(5) = esn - (val * ((two * trn) - one))
      splc = stat(5)
c
      end if
      return
c BANDET.FOR, 1985-06-03
c
c***********************************************************************
c
c SUBROUTINE BANDET (REAL*8)
c
c Purpose:
c *******
c
c       This subroutine computes the LU decomposition of an N*N matrix
c       E. It is assumed that E has M bands above and M bands below the
c       diagonal. The decomposition is returned in E. It is assumed that
c       E can be decomposed without pivoting. The matrix E is stored in
c       vectorized form in the array E(-M:M,N), where element E(J,I) of
c       the array E corresponds with element e(i,i+j) of the matrix E.
c
c Calling convention:
c ******************
c
c       CALL BANDET ( E, M, N )
c
c Meaning of parameters:
c *********************
c
c       E(-M:M,N)       (I/O)   Matrix to be decomposed.
c       M, N            ( I )   Matrix dimensioning parameters,
c                               M >= 0, N >= 2*M.
c
c Remark:
c ******
c
c       No checking on the validity of the input data is performed.
c       If (M.le.0), no action is taken.
c
c***********************************************************************
c
      end
c
      subroutine bandet(e, m, n)
      implicit double precision (o-z, a-h)
c
      dimension e(- m:m, n)
      if (m .le. 0) return
      do 40 i = 1, n
      di = e(0,i)
      mi = min0(m,i - 1)
      if (mi .ge. 1) then
      do 10 k = 1, mi
      di = di - (e(- k,i) * e(k,i - k))
   10 continue
      e(0,i) = di
      end if
      lm = min0(m,n - i)
      if (lm .ge. 1) then
      do 30 l = 1, lm
      dl = e(- l,i + l)
      km = min0(m - l,i - 1)
      if (km .ge. 1) then
      du = e(l,i)
      do 20 k = 1, km
      du = du - (e(- k,i) * e(l + k,i - k))
      dl = dl - (e((- l) - k,l + i) * e(k,i - k))
   20 continue
      e(l,i) = du
      end if
      e(- l,i + l) = dl / di
   30 continue
      end if
c
c***  Ready
c
   40 continue
      return
c BANSOL.FOR, 1985-12-12
c
c***********************************************************************
c
c SUBROUTINE BANSOL (REAL*8)
c
c Purpose:
c *******
c
c       This subroutine solves systems of linear equations given an LU
c       decomposition of the design matrix. Such a decomposition is pro-
c       vided by subroutine BANDET, in vectorized form. It is assumed
c       that the design matrix is not singular.
c
c Calling convention:
c ******************
c
c       CALL BANSOL ( E, Y, NY, C, NC, M, N, K )
c
c Meaning of parameters:
c *********************
c
c       E(-M:M,N)       ( I )   Input design matrix, in LU-decomposed,
c                               vectorized form. Element E(J,I) of the
c                               array E corresponds with element
c                               e(i,i+j) of the N*N design matrix E.
c       Y(NY,K)         ( I )   Right hand side vectors.
c       C(NC,K)         ( O )   Solution vectors.
c       NY, NC, M, N, K ( I )   Dimensioning parameters, with M >= 0,
c                               N > 2*M, and K >= 1.
c
c Remark:
c ******
c
c       This subroutine is an adaptation of subroutine BANSOL from the
c       paper by Lyche et al. (1983). No checking is performed on the
c       validity of the input parameters and data. Division by zero may
c       occur if the system is singular.
c
c Reference:
c *********
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      subroutine bansol(e, y, ny, c, nc, m, n, k)
      implicit double precision (o-z, a-h)
c
c***  Check on special cases: M=0, M=1, M>1
c
      dimension e(- m:m, n), y(ny, k), c(nc, k)
      nm1 = n - 1
c
c***  M = 0: Diagonal system
c
      if (m - 1) 10, 40, 80
   10 do 30 i = 1, n
      do 20 j = 1, k
      c(i,j) = y(i,j) / e(0,i)
   20 continue
   30 continue
c
c***  M = 1: Tridiagonal system
c
      return
   40 do 70 j = 1, k
      c(1,j) = y(1,j)
cForward sweep
      do 50 i = 2, n
      c(i,j) = y(i,j) - (e(-1,i) * c(i - 1,j))
   50 continue
      c(n,j) = c(n,j) / e(0,n)
cBackward sweep
      do 60 i = nm1, 1, -1
      c(i,j) = (c(i,j) - (e(1,i) * c(i + 1,j))) / e(0,i)
   60 continue
   70 continue
c
c***  M > 1: General system
c
      return
   80 do 130 j = 1, k
      c(1,j) = y(1,j)
cForward sweep
      do 100 i = 2, n
      mi = min0(m,i - 1)
      d = y(i,j)
      do 90 l = 1, mi
      d = d - (e(- l,i) * c(i - l,j))
   90 continue
      c(i,j) = d
  100 continue
      c(n,j) = c(n,j) / e(0,n)
cBackward sweep
      do 120 i = nm1, 1, -1
      mi = min0(m,n - i)
      d = c(i,j)
      do 110 l = 1, mi
      d = d - (e(l,i) * c(i + l,j))
  110 continue
      c(i,j) = d / e(0,i)
  120 continue
  130 continue
c
      return
c TRINV.FOR, 1985-06-03
c
c***********************************************************************
c
c FUNCTION TRINV (REAL*8)
c
c Purpose:
c *******
c
c       To calculate TRACE [ B * E**-1 ], where B and E are N * N
c       matrices with bandwidth 2*M+1, and where E is a regular matrix
c       in LU-decomposed form. B and E are stored in vectorized form,
c       compatible with subroutines BANDET and BANSOL.
c
c Calling convention:
c ******************
c
c       TRACE = TRINV ( B, E, M, N )
c
c Meaning of parameters:
c *********************
c
c       B(-M:M,N)       ( I ) Input array for matrix B. Element B(J,I)
c                             corresponds with element b(i,i+j) of the
c                             matrix B.
c       E(-M:M,N)       (I/O) Input array for matrix E. Element E(J,I)
c                             corresponds with element e(i,i+j) of the
c                             matrix E. This matrix is stored in LU-
c                             decomposed form, with L unit lower tri-
c                             angular, and U upper triangular. The unit
c                             diagonal of L is not stored. Upon return,
c                             the array E holds the central 2*M+1 bands
c                             of the inverse E**-1, in similar ordering.
c       M, N            ( I ) Array and matrix dimensioning parameters
c                             (M.gt.0, N.ge.2*M+1).
c       TRINV           ( O ) Output function value TRACE [ B * E**-1 ]
c
c Reference:
c *********
c
c       A.M. Erisman & W.F. Tinney, On computing certain elements of the
c       inverse of a sparse matrix. Communications of the ACM 18(1975),
c       nr. 3, pp. 177-179.
c
c***********************************************************************
c
      end
c
      double precision function trinv(b, e, m, n)
      implicit double precision (o-z, a-h)
      parameter (zero = 0d0, one = 1d0)
c
c***  Assess central 2*M+1 bands of E**-1 and store in array E
c
      dimension b(- m:m, n), e(- m:m, n)
cNth pivot
      e(0,n) = one / e(0,n)
      do 40 i = n - 1, 1, -1
      mi = min0(m,n - i)
c***     Save Ith column of L and Ith row of U, and normalize U row
cIth pivot
      dd = one / e(0,i)
      do 10 k = 1, mi
cIth row of U (normalized)
      e(k,n) = e(k,i) * dd
cIth column of L
      e(- k,1) = e(- k,k + i)
   10 continue
c***     Invert around Ith pivot
      dd = dd + dd
      do 30 j = mi, 1, -1
      du = zero
      dl = zero
      do 20 k = 1, mi
      du = du - (e(k,n) * e(j - k,i + k))
      dl = dl - (e(- k,1) * e(k - j,i + j))
   20 continue
      e(j,i) = du
      e(- j,j + i) = dl
      dd = dd - ((e(j,n) * dl) + (e(- j,1) * du))
   30 continue
      e(0,i) = 5d-1 * dd
c
c***  Assess TRACE [ B * E**-1 ] and clear working storage
c
   40 continue
      dd = zero
      do 60 i = 1, n
      mn = - min0(m,i - 1)
      mp = min0(m,n - i)
      do 50 k = mn, mp
      dd = dd + (b(k,i) * e(- k,k + i))
   50 continue
   60 continue
      trinv = dd
      do 70 k = 1, m
      e(k,n) = zero
      e(- k,1) = zero
c
c***  Ready
c
   70 continue
      return
c SPLDER.FOR, 1985-06-11
c
c***********************************************************************
c
c FUNCTION SPLDER (REAL*8)
c
c Purpose:
c *******
c
c       To produce the value of the function (IDER.eq.0) or of the
c       IDERth derivative (IDER.gt.0) of a 2M-th order B-spline at
c       the point T. The spline is described in terms of the half
c       order M, the knot sequence X(N), N.ge.2*M, and the spline
c       coefficients C(N).
c
c Calling convention:
c ******************
c
c       SVIDER = SPLDER ( IDER, M, N, T, X, C, L, Q )
c
c Meaning of parameters:
c *********************
c
c       SPLDER  ( O )   Function or derivative value.
c       IDER    ( I )   Derivative order required, with 0.le.IDER
c                       and IDER.le.2*M. If IDER.eq.0, the function
c                       value is returned; otherwise, the IDER-th
c                       derivative of the spline is returned.
c       M       ( I )   Half order of the spline, with M.gt.0.
c       N       ( I )   Number of knots and spline coefficients,
c                       with N.ge.2*M.
c       T       ( I )   Argument at which the spline or its deri-
c                       vative is to be evaluated, with X(1).le.T
c                       and T.le.X(N).
c       X(N)    ( I )   Strictly increasing knot sequence array,
c                       X(I-1).lt.X(I), I=2,...,N.
c       C(N)    ( I )   Spline coefficients, as evaluated by
c                       subroutine GVCSPL.
c       L       (I/O)   L contains an integer such that:
c                       X(L).le.T and T.lt.X(L+1) if T is within
c                       the range X(1).le.T and T.lt.X(N). If
c                       T.lt.X(1), L is set to 0, and if T.ge.X(N),
c                       L is set to N. The search for L is facili-
c                       tated if L has approximately the right
c                       value on entry.
c       Q(2*M)  ( W )   Internal work array.
c
c Remark:
c ******
c
c       This subroutine is an adaptation of subroutine SPLDER of
c       the paper by Lyche et al. (1983). No checking is performed
c       on the validity of the input parameters.
c
c Reference:
c *********
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      double precision function splder(ider, m, n, t, x, c, l, q)
      implicit double precision (o-z, a-h)
      parameter (zero = 0d0, one = 1d0)
cf2py intent(out) :: splder
cf2py intent(hide) :: q
c
c***  Derivatives of IDER.ge.2*M are alway zero
c
      dimension x(n), c(n), q(2 * m)
      m2 = 2 * m
      k = m2 - ider
      if (k .lt. 1) then
      splder = zero
      return
c
c***  Search for the interval value L
c
      end if
c
c***  Initialize parameters and the 1st row of the B-spline
c***  coefficients tableau
c
      call search(n, x, t, l)
      tt = t
      mp1 = m + 1
      npm = n + m
      m2m1 = m2 - 1
      k1 = k - 1
      nk = n - k
      lk = l - k
      lk1 = lk + 1
      lm = l - m
      jl = l + 1
      ju = l + m2
      ii = n - m2
      ml = - l
      do 2 j = jl, ju
      if ((j .ge. mp1) .and. (j .le. npm)) then
      q(j + ml) = c(j - m)
      else
      q(j + ml) = zero
      end if
c
c***  The following loop computes differences of the B-spline
c***  coefficients. If the value of the spline is required,
c***  differencing is not necessary.
c
    2 continue
      if (ider .gt. 0) then
      jl = jl - m2
      ml = ml + m2
      do 6 i = 1, ider
      jl = jl + 1
      ii = ii + 1
      j1 = max0(1,jl)
      j2 = min0(l,ii)
      mi = m2 - i
      j = j2 + 1
      if (j1 .le. j2) then
      do 3 jin = j1, j2
      j = j - 1
      jm = ml + j
      q(jm) = (q(jm) - q(jm - 1)) / (x(j + mi) - x(j))
    3 continue
      end if
      if (jl .ge. 1) goto 6
      i1 = i + 1
      j = ml + 1
      if (i1 .le. ml) then
      do 5 jin = i1, ml
      j = j - 1
      q(j) = - q(j - 1)
    5 continue
      end if
    6 continue
      do 7 j = 1, k
      q(j) = q(j + ider)
    7 continue
c
c***  Compute lower half of the evaluation tableau
c
      end if
cTableau ready if IDER.eq.2*M-1
      if (k1 .ge. 1) then
      do 14 i = 1, k1
      nki = nk + i
      ir = k
      jj = l
      ki = k - i
c***        Right-hand B-splines
      nki1 = nki + 1
      if (l .ge. nki1) then
      do 9 j = nki1, l
      q(ir) = q(ir - 1) + ((tt - x(jj)) * q(ir))
      jj = jj - 1
      ir = ir - 1
    9 continue
c***        Middle B-splines
      end if
      lk1i = lk1 + i
      j1 = max0(1,lk1i)
      j2 = min0(l,nki)
      if (j1 .le. j2) then
      do 11 j = j1, j2
      xjki = x(jj + ki)
      z = q(ir)
      q(ir) = z + (((xjki - tt) * (q(ir - 1) - z)) / (xjki - x(jj)))
      ir = ir - 1
      jj = jj - 1
   11 continue
c***        Left-hand B-splines
      end if
      if (lk1i .le. 0) then
      jj = ki
      lk1i1 = 1 - lk1i
      do 13 j = 1, lk1i1
      q(ir) = q(ir) + ((x(jj) - tt) * q(ir - 1))
      jj = jj - 1
      ir = ir - 1
   13 continue
      end if
   14 continue
c
c***  Compute the return value
c
      end if
c***  Multiply with factorial if IDER.gt.0
      z = q(k)
      if (ider .gt. 0) then
      do 16 j = k, m2m1
      z = z * j
   16 continue
      end if
c
c***  Ready
c
      splder = z
      return
c SEARCH.FOR, 1985-06-03
c
c***********************************************************************
c
c SUBROUTINE SEARCH (REAL*8)
c
c Purpose:
c *******
c
c       Given a strictly increasing knot sequence X(1) < ... < X(N),
c       where N >= 1, and a real number T, this subroutine finds the
c       value L such that X(L) <= T < X(L+1).  If T < X(1), L = 0;
c       if X(N) <= T, L = N.
c
c Calling convention:
c ******************
c
c       CALL SEARCH ( N, X, T, L )
c
c Meaning of parameters:
c *********************
c
c       N       ( I )   Knot array dimensioning parameter.
c       X(N)    ( I )   Stricly increasing knot array.
c       T       ( I )   Input argument whose knot interval is to
c                       be found.
c       L       (I/O)   Knot interval parameter. The search procedure
c                       is facilitated if L has approximately the
c                       right value on entry.
c
c Remark:
c ******
c
c       This subroutine is an adaptation of subroutine SEARCH from
c       the paper by Lyche et al. (1983). No checking is performed
c       on the input parameters and data; the algorithm may fail if
c       the input sequence is not strictly increasing.
c
c Reference:
c *********
c
c       T. Lyche, L.L. Schumaker, & K. Sepehrnoori, Fortran subroutines
c       for computing smoothing and interpolating natural splines.
c       Advances in Engineering Software 5(1983)1, pp. 2-5.
c
c***********************************************************************
c
      end
c
      subroutine search(n, x, t, l)
      implicit double precision (o-z, a-h)
c
      dimension x(n)
c***     Out of range to the left
      if (t .lt. x(1)) then
      l = 0
      return
      end if
c***     Out of range to the right
      if (t .ge. x(n)) then
      l = n
      return
c***  Validate input value of L
      end if
      l = max0(l,1)
c
c***  Often L will be in an interval adjoining the interval found
c***  in a previous call to search
c
      if (l .ge. n) l = n - 1
      if (t .ge. x(l)) goto 5
      l = l - 1
c
c***  Perform bisection
c
      if (t .ge. x(l)) return
      il = 1
    3 iu = l
    4 l = (il + iu) / 2
      if ((iu - il) .le. 1) return
      if (t .lt. x(l)) goto 3
      il = l
      goto 4
    5 if (t .lt. x(l + 1)) return
      l = l + 1
      if (t .lt. x(l + 1)) return
      il = l + 1
      iu = n
c
      goto 4
      end


REAL(KIND=8) FUNCTION D1MACH(I)

  INTEGER,INTENT(IN):: I
  !
  !  DOUBLE-PRECISION MACHINE CONSTANTS
  !  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
  !  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
  !  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
  !  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
  !  D1MACH( 5) = LOG10(B)
  !
  REAL(KIND=8),DIMENSION(5),SAVE::X
  LOGICAL,SAVE:: ran = .false.

  IF(.NOT. ran)THEN

     X(1) = TINY(X(1))
     X(2) = HUGE(X(2))
     X(3) = EPSILON(X(3))/RADIX(X(3))
     X(4) = EPSILON(X(4))
     X(5) = LOG10(REAL(RADIX(X(5)),KIND=8))
     ran = .true.

  END IF

  IF (I < 1 .OR. I > 5) THEN

     WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
     STOP

  END IF

  D1MACH = X(I)

  RETURN

END FUNCTION D1MACH


! { dg-do run }
! { dg-options "-O2 -ffast-math -mfpmath=387" { target { { i?86-*-* x86_64-*-* } && { ! { ia32 } } } } }
! { dg-options "-O2 -ffast-math" }

module scc_m
  implicit none
  integer, parameter :: dp = selected_real_kind(15,90)
contains
  subroutine self_ind_cir_coil (r, l, turns, mu, self_l)
  implicit none
  real (kind = dp), intent(in) :: r, l, turns, mu
  real (kind = dp), intent(out) :: self_l
  real (kind = dp) :: alpha, modulus, pk, ak, bk, ae, be, elliptice, elliptick
  real (kind = dp) :: expected
  alpha = atan(2.0_dp*r/l)
  modulus = sin(alpha)
  pk = 1.0_dp - modulus**2
  ak = (((0.01451196212_dp*pk+0.03742563713_dp)*pk+ &
         0.03590092383_dp)*pk+0.09666344259_dp)*pk+1.38629436112_dp
  bk = (((0.00441787012_dp*pk+0.03328355346_dp)*pk+ &
         0.06880248576_dp)*pk+0.12498593597_dp)*pk+0.5_dp
  elliptick = ak - bk * log(pk)
  ae = (((0.01736506451_dp*pk+0.04757383546_dp)*pk+ &
         0.0626060122_dp)*pk+0.44325141463_dp)*pk+1.0_dp
  be = (((0.00526449639_dp*pk+0.04069697526_dp)*pk+ &
         0.09200180037_dp)*pk+0.2499836831_dp)*pk
  elliptice = ae - be * log(pk)
  self_l = (mu * turns**2 * l**2 * 2.0_dp * r)/3.0_dp * &
           (((tan(alpha)**2-1.0_dp)*elliptice+elliptick)/sin(alpha) - &
            tan(alpha)**2)
  expected = 3.66008420600434162E-002_dp
  if (abs(self_l - expected) / expected > 1e-3) &
        call abort
  end subroutine self_ind_cir_coil
end module scc_m

program test
  use scc_m
  implicit none

  real (kind = dp) :: mu, turns, r, l, self_l
  mu = 1.25663706143591729E-006_dp
  turns = 166666.66666666666_dp
  l = 3.00000000000000006E-003_dp
  r = 2.99999999999999989E-002_dp

  call self_ind_cir_coil (r, l, turns, mu, self_l)
end program test


! ---------------------------------------------------------------------------------------------------------------
! ORIGINAL AUTHORS : MIKE BLASKIEWISC, RODERIK BRUCE, MICHAELA SCHAUMANN, TOM MERTENS
! ---------------------------------------------------------------------------------------------------------------
! VERSION 2.0 : UPDATE TO TRACK MULTIPLE BUNCHES AND HAVE DIFFERENT PARTICLE TYPES (P-PB)
!   AUTHOR    : TOM MERTENS
!   DATE      : 19/12/2016
!   COPYRIGHT : CERN
!
!   DESCRIPTION :
!       FUNCTION TO CALCULATE FMOHL A HELPER FUNCTION IN THE NAGAITSEV IBS MODULE
! ---------------------------------------------------------------------------------------------------------------

double precision function fmohl(a,b,q,np)
integer, intent(in) ::np
double precision, intent(in) :: a,b,q
double precision :: du,u,cp,cq,dsum,sum

! direct crib from page 126 in handbook
      ceuler = 0.577215
      pi = 3.14159265
      sum = 0
      du = 1/float(np)
      do k=0,np
         u = k*du
         cp = sqrt(a*a+(1-a*a)*u*u)
         cq = sqrt(b*b+(1-b*b)*u*u)
         dsum = 2*log(q*(1/cp+1/cq)/2) - ceuler
         dsum = dsum*(1-3*u*u)/(cp*cq)
         if(k.eq.0)dsum=dsum/2
         if(k.eq.np)dsum=dsum/2
         sum = sum + dsum
      enddo
      fmohl = 8*pi*du*sum
!      write(6,*)'a,b,q,fmohl',a,b,q,fmohl
      return
end


!---------------------------------------------------------------*

!
! This subroutine finds the inverse of a 3x3 matrix and finds
! its determinant
!
! Andrew Spakowitz
! Written 9-1-04

      subroutine MinV(A,B,DET)

      real(dp) A(3,3)        ! Original matrix
      real(dp) B(3,3)        ! Inverse matrix
      real(dp) DET        ! Determinant
      real(dp) COA(3,3)        ! Cofactor of A

! First find the determinant

      DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) + A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3)) + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))

! Find the Cofactor of A

      COA(1,1) = A(2,2)*A(3,3)-A(2,3)*A(3,2)
      COA(1,2) = -(A(2,1)*A(3,3)-A(2,3)*A(3,1))
      COA(1,3) = A(2,1)*A(3,2)-A(2,2)*A(3,1)
      COA(2,1) = -(A(1,2)*A(3,3)-A(1,3)*A(3,2))
      COA(2,2) = A(1,1)*A(3,3)-A(1,3)*A(3,1)
      COA(2,3) = -(A(1,1)*A(3,2)-A(1,2)*A(3,1))
      COA(3,1) = A(1,2)*A(2,3)-A(1,3)*A(2,2)
      COA(3,2) = -(A(1,1)*A(2,3)-A(1,3)*A(2,1))
      COA(3,3) = A(1,1)*A(2,2)-A(1,2)*A(2,1)

! Find the inverse of A

      B(1,1) = COA(1,1)/DET
      B(1,2) = COA(2,1)/DET
      B(1,3) = COA(3,1)/DET
      B(2,1) = COA(1,2)/DET
      B(2,2) = COA(2,2)/DET
      B(2,3) = COA(3,2)/DET
      B(3,1) = COA(1,3)/DET
      B(3,2) = COA(2,3)/DET
      B(3,3) = COA(3,3)/DET

      RETURN
      END

!---------------------------------------------------------------*


program temperature_conversion

implicit none
call test_fahrenheit_to_celsius()

contains

function fahrenheit_to_celsius(temp_f) result(temp_c)
   implicit none
   real temp_f
   real temp_c
   temp_c = (temp_f - 32.0) * (5.0/9.0)
end function fahrenheit_to_celsius

subroutine test_fahrenheit_to_celsius()
   implicit none
   real temp_c
   real expected_result
   temp_c = fahrenheit_to_celsius(100.0)
   expected_result = 37.777777
   if( abs(temp_c - expected_result) > 1.0e-6) then
      write(*,*) 'Error'
   else
      write(*,*) 'Pass'
   end if
end subroutine test_fahrenheit_to_celsius

end program temperature_conversion


! The first two consecutive numbers to have two distinct prime factors are:
!
! 14 = 2 × 7
! 15 = 3 × 5
!
! The first three consecutive numbers to have three distinct prime factors
! are:
!
! 644 = 2² × 7 × 23
! 645 = 3 × 5 × 43
! 646 = 2 × 17 × 19.
!
! Find the first four consecutive integers to have four distinct prime factors
! each. What is the first of these numbers?
!
! Project Euler: 47
!
! Answer: 134043

program main

        use euler

implicit none

        ! This code starts by picking a number and then adding to it to see if
        ! the number of factors is equal to the number that we are looking for.
        ! If so, it checks the next consecutive number to see if it too has the
        ! same property.  If in any event that it does not, but has passed the
        ! zero threshold, we can add the number that did pass the constraint
        ! and move one past that for we know that those integers have been
        ! check and will not contribute to a successful solution.

        integer (int32), parameter :: N_CONSEC = 4;
        integer (int32) :: c, i;

        c = 0; i = 0;

        do while (c /= N_CONSEC)

                call inc(i, (c + 1));
                c = 0;

                do while(count_factors(i + c) == N_CONSEC .AND. c < N_CONSEC)
                        call inc(c, 1);
                end do

        end do

        call printint(i);

contains

        ! We remove all factors of two so that we can iterate via two, by only
        ! checking the odd numbers henceforth. We also divide by the number
        ! which is a factor such that we arrive at our upper limit sooner. If
        ! `n` is equal to one, then this means that we successfully got all the
        ! prime factors. If not, then it must in fact be a prime, and thus we
        ! must add this for we don't iterate up to the original number itself

        function count_factors(n)

                integer (int32) :: count_factors, n, i;

                count_factors = intbool(.NOT. BTEST(n, 0));

                do while (.NOT. BTEST(n, 0)); n = ISHFT(n, -1); end do;

                i = 3;

                do while ((i * i) < n)

                        call inc(count_factors, intbool(mod(n, i) == 0));

                        do while (mod(n, i) == 0)
                                n = n / i;
                        end do

                        call inc(i, 2);
                end do

                call inc(count_factors, intbool(n > 1));

        end function count_factors

        ! This function directly replicates the integer equivalence of booleans
        ! in C. This is solid functionality that it turns out I can't live
        ! without.

        pure function intbool(logical)

                integer (int32) :: intbool;
                logical, intent(in) :: logical

                intbool = merge(1, 0, (logical));

        end function intbool

end program main


!> Utility and math functions
module coneangle_util
  use coneangle_env, only: wp
  implicit none(type, external)

  private
  public :: binomial, cross_product, get_distances, solve_quadratic, vector_angle

contains
  pure function binomial(n, k)
    !! Returns binomial coefficient \( \binom{n}{k} \)
    !> n
    integer, intent(in) :: n
    !> k
    integer, intent(in) :: k
    !> Binomial coefficient
    integer :: binomial

    binomial = nint(exp(log_gamma(n + 1.0_wp) - log_gamma(n - k + 1.0_wp) - log_gamma(k + 1.0_wp)))
  end function binomial

  pure function cross_product(a, b)
    !! Returns cross product between two vectors  \( a \times b \)
    !> First vector
    real(wp), intent(in) :: a(3)
    !> Second vector
    real(wp), intent(in) :: b(3)
    !> Cross product
    real(wp) :: cross_product(3)

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

  pure function get_distances(a, b) result(distances)
    !! Calculate distance between point and group of points
    !> Point
    real(wp), intent(in) :: a(:)
    !> Group of points
    real(wp), intent(in) :: b(:, :)
    !> Distances
    real(wp) :: distances(size(b, 2))

    distances = norm2(spread(a, 2, size(b, 2)) - b, 1)
  end function get_distances

  pure function solve_quadratic(a, b, c) result(roots)
    !! Return roots for quadratic equation  \( ax^2 + bx + c = 0 \)
    !> a*x**2
    real(wp), intent(in) :: a
    !> b*x
    real(wp), intent(in) :: b
    !> c
    real(wp), intent(in) :: c
    !> Roots
    complex(wp) :: roots(2)

    associate (delta => sqrt(cmplx(b**2 - 4*a*c, kind=wp)))
      roots(1) = (-b + delta)/(2*a)
      roots(2) = (-b - delta)/(2*a)
    end associate
  end function solve_quadratic

  pure function vector_angle(a, b) result(angle)
  !! Calculate angle between vectors
    !> First vector
    real(wp), intent(in) :: a(3)
    !> Second vector
    real(wp), intent(in) :: b(3)
    !> Angle (radians)
    real(wp) :: angle

    angle = atan2(norm2(cross_product(a, b)), dot_product(a, b))
  end function vector_angle
end module coneangle_util


!##############################################################################
! PROGRAM oligopoly2
!
! ## Multi-dimensional rootfinding using the Gauss-Seidel iteration approach
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program oligopoly2

    implicit none
    real*8 :: eta = 1.6d0
    real*8 :: c(2) = (/ 0.6d0, 0.8d0 /)
    real*8 :: qold(2), q(2), QQ, damp
    integer :: iter

    ! initialize q
    qold = 0.1d0
    damp = 0.7d0

    do iter = 1, 100

        QQ = sum(qold)
        q = 1d0/c*(QQ**(-1d0/eta)-1d0/eta*QQ**(-1d0/eta-1d0)*qold)
        q = damp*q + (1d0-damp)*qold

        ! write to screen
        write(*, '(a, i5,2f10.4)')'Iter: ', iter, q(1), q(2)

        ! check for convergence
        if( all(abs(q-qold) < 1d-6))then
            write(*,'(/a, 2f10.4)')'   Output', q(1), q(2)
            stop
        endif

        ! update q
        qold = q
    enddo

end program


PROGRAM main
!
! Purpose:
!  Just for homework 8 in chapter6
!
! Record of revisions:
!    Date   Programmer  Description of change
!    ====   ==========  =====================
!  04/12/17  hopeful       Original code
!
IMPLICIT NONE
INTEGER :: I
INTEGER :: countA, countB

countA = 1
countB = 1
DO I = 0, 24, 6
    call CMA(1, I, countA)
    call CMB(1, I, countB)
    WRITE (*,*) 'After ', I, ' hours, culture medium A has ', countA, ' germs.'
    WRITE (*,*) 'After ', I, ' hours, culture medium B has ', countB, ' germs.'
END DO

END PROGRAM main

SUBROUTINE CMA (icount, time, fcount)
IMPLICIT NONE

INTEGER :: icount  ! 初始数目
INTEGER :: time    ! 培养时间(h)
INTEGER :: fcount  ! 最终数目

fcount = icount * 2 ** (time * 60 / 90)

END SUBROUTINE CMA

SUBROUTINE CMB (icount, time, fcount)
IMPLICIT NONE

INTEGER :: icount  ! 初始数目
INTEGER :: time    ! 培养时间(h)
INTEGER :: fcount  ! 最终数目

fcount = icount * 2 ** (time * 60 / 120)

END SUBROUTINE CMB


module d_pend
  integer, parameter :: dp2 = kind(1.0d0)
  real(dp2) :: l1, l2, m1, m2, ms
end module d_pend

program main
  use d_pend
  implicit none
  call d_pend_stat
  call d_pend_adapt
end program main

subroutine d_pend_stat
  use d_pend
  use ode_int
  implicit none
  integer, parameter :: n = 4
  real(dp), parameter :: rad = atan(1._dp)/45._dp
  real(dp) :: t, dt, tmax, dtheta
  real(dp) :: yi(n)
  real(dp), dimension(size(yi)) :: yf, dydt, er
  real(dp) :: start, finish
  interface
    subroutine d_pend_deriv(t,y,dydt)
      implicit none
      real(dp), intent(in) :: t, y(:)
      real(dp), intent(out) :: dydt(:)
    end subroutine d_pend_deriv
  end interface

  open(unit=1, file = 'd_pend_stat.plt')
  ! Initial conditions.
  t = 0._dp
  tmax = 50._dp
  dt = 5.d-3
  l1     = 5._dp
  l2     = 9._dp
  m1     = 13._dp
  m2     = 50._dp
  yi(1)  = 173._dp*rad
  yi(2)  = -86._dp*rad
  dydt(1) = -3._dp*rad
  dydt(2) = 35._dp*rad
  ms     = m1 + m2
  dtheta   = yi(1) - yi(2)
  yi(3)  = ms*l1*l1*dydt(1) + m2*l1*l2*dydt(2)*cos(dtheta)
  yi(4)  = m2*l2*l2*dydt(2) + m2*l1*l2*dydt(1)*cos(dtheta)
  ! Print initial conditions.
  write(1,*) t,yi(1),yi(2),yi(3),yi(4),l1*sin(yi(1)),-l1*cos(yi(1)),l1*sin(yi(1))+l2*sin(yi(2)),-l1*cos(yi(1))-l2*cos(yi(2))

  call cpu_time(start)
  do while (t < tmax)
    call rkck(d_pend_deriv,t,yi,yf,er,dt)
    ! Preparing next step.
    t = t + dt
    yi(:) = yf(:)
    ! Writing current results.
    write(1,*) t,yf(1),yf(2),yf(3),yf(4),l1*sin(yf(1)),-l1*cos(yf(1)),l1*sin(yf(1))+l2*sin(yf(2)),-l1*cos(yf(1))-l2*cos(yf(2))
  end do
  call cpu_time(finish)
  print '("Time = ",f6.3," seconds.")',finish-start
end subroutine d_pend_stat

subroutine d_pend_adapt
  use d_pend
  use ode_int
  implicit none
  integer, parameter :: n = 4
  real(dp), parameter :: rad = atan(1.)/45.
  real(dp) t, dt, dtmin, tmax, dtheta, der
  real(dp) y(n)
  real(dp), dimension(size(y)) :: dydt, er
  real(dp) start, finish
  interface
    subroutine d_pend_deriv(t,y,dydt)
      implicit none
      real(dp), intent(in) :: t, y(:)
      real(dp), intent(out) :: dydt(:)
    end subroutine
  end interface

  open(unit=1, file = 'd_pend_adapt.plt')
  ! Initial conditions.
  t = 0._dp
  tmax = 50._dp
  dt     = 5.d-3
  dtmin  = 4.375d-3
  der    = 1.3125d-7
  l1     = 5._dp
  l2     = 9._dp
  m1     = 13._dp
  m2     = 50._dp
  y(1)  = 173._dp*rad
  y(2)  = -86._dp*rad
  dydt(1) = -3._dp*rad
  dydt(2) = 35._dp*rad
  ms     = m1 + m2
  dtheta   = y(1) - y(2)
  y(3)  = ms*l1*l1*dydt(1) + m2*l1*l2*dydt(2)*cos(dtheta)
  y(4)  = m2*l2*l2*dydt(2) + m2*l1*l2*dydt(1)*cos(dtheta)
  ! Print initial conditions.
  write(1,*) t,y(1),y(2),y(3),y(4),l1*sin(y(1)),-l1*cos(y(1)),l1*sin(y(1))+l2*sin(y(2)),-l1*cos(y(1))-l2*cos(y(2))

  call cpu_time(start)
  do while (t < tmax)
    call rkcka(d_pend_deriv,t,y,der,dt,dtmin)
    ! Writing current results.
    write(1,*) t,y(1),y(2),y(3),y(4),l1*sin(y(1)),-l1*cos(y(1)),l1*sin(y(1))+l2*sin(y(2)),-l1*cos(y(1))-l2*cos(y(2))
  end do
  call cpu_time(finish)
  print '("Time = ",f6.3," seconds.")',finish-start
end subroutine d_pend_adapt

subroutine d_pend_deriv(t,y,dydt)
! y(1) = theta1    dydt(1) = theta1'
! y(2) = theta2    dydt(2) = theta2'
! y(3) = p1        dydt(3) = p1'
! y(4) = p2        dydt(4) = p2'
use d_pend
implicit none
real(dp2) :: dtheta, den, c1, c2
real(dp2), intent(in) :: t, y(:)
real(dp2), intent(out):: dydt(:)
real(dp2), parameter :: g = 9.81_dp2
dtheta   = y(1) - y(2)
den   = m1 + m2*sin(dtheta)*sin(dtheta)
c1    = (y(3)*y(4)*sin(dtheta))/(l1*l2*den)
c2    = (l2*l2*m2*y(3)*y(3) + l1*l1*ms*y(4)*y(4) - l1*l2*m2*y(3)*y(4)*cos(dtheta))/(2*l1*l1*l2*l2*den*den)*sin(2*dtheta)
dydt(1) = (l2*y(3)-l1*y(4)*cos(dtheta))/(l1*l1*l2*den)
dydt(2) = (l1*ms*y(4)-l2*m2*y(3)*cos(dtheta))/(l1*l2*l2*m2*den)
dydt(3) = -ms*g*l1*sin(y(1)) - c1 + c2
dydt(4) = -m2*g*l2*sin(y(2)) + c1 - c2
end subroutine d_pend_deriv


subroutine jacobi(a, b, u, eps, nmaxit, ier)
  implicit none

  real(8), dimension(:,:), intent(in) :: a
  real(8), dimension(:), intent(in) :: b
  real(8), dimension(:), intent(out) :: u
  real(8), intent(in) :: eps
  integer, intent(in) :: nmaxit
  integer, intent(out) :: ier

  real(8), dimension(:), allocatable :: v
  real(8) :: s, err
  integer :: n, i, j, k

  n = size(b)

  allocate(v(n))

  do k=1, nmaxit
    print*,
    print*,'Iterante',k
    print*,u(:)
    print*,
    err = 0
    do i=1,n
      s = 0
      do j = 1, i-1
        s = s + a(i,j)*u(j)
      end do

      do j = i+1, n
          s = s + a(i,j)*u(j)
      end do

      v(i) = (b(i) - s)/a(i,i)
    end do

    do i = 1, n
        err = err + abs(v(i))
        u(i) = v(i)
    end do

    if(err < eps) then
      ier = 0
      return
    end if
  end do
  ier = 1
end subroutine


program prime_number_function
    implicit none
    integer, parameter :: n_min = 1, n_max = 40
    integer :: n

    do n = n_min, n_max
        if (is_prime(n)) then
            print *, n, 'prime'
        else
            print *, n, 'not prime'
        end if
      end do

contains

    logical function is_prime(n)
        implicit none
        integer, intent(in) :: n
        integer :: divisor

        if (n == 1) then
            is_prime = .false.
        else
            is_prime = .true.
            do divisor = 2, n/2
                if (mod(n, divisor) == 0) then
                    is_prime = .false.
                    exit
                end if
            end do
        end if
    end function is_prime

end program prime_number_function


      program main
c
c   compute zt and zw (layer mid points and boundaries) using
c   sin^2 stretching in BL, fixed dz above, increasing aloft
c
      integer, parameter :: nz = 96

      real zt(nz)
      real zw(nz+1)

c     ... input parameters

c     ... top of domain (m)
      domain_H = 1500.

c     ... minimum dz (m)
      dzmin = 5.0

c     ... thickness of layers in normalized (bar) units
      dz = domain_H / nz

c     ... heights of dz minimum aloft and overlying dz minimum (m)
      zi = 800.
      zf = 925.

c     ... possibly adjust dzmin to fit evenly between zi and zf
      if ( zi < zf ) then
        nzmin = nint((zf - zi)/dzmin)
        dzmin = (zf - zi)/nzmin
      endif

c     ... fraction of grid below zi
      fzi = 0.55

c     ... indices of zi and zf
      ki = nint(fzi*nz)
      kf = ki + (zf - zi)/dzmin

c     ... normalized zi and zf
      zibar = dz*ki
      zfbar = dz*kf

c     ... ratio of minimum dz to H/nz
      fmin = dzmin / dz

c     ... derived parameters
      const_PI = 2*acos(0.)

      b = (2.0)*( (zi/zibar) - fmin )
      d = (3.0/((domain_H - zfbar)**2) )*(
     &     (domain_H - zf)/(domain_H - zfbar) - fmin )

c     ... impossible grids
      if ( kf < ki .or. kf > nz+1 ) then
         print *, 'Error :: ki, kf, nz = ', ki, kf, nz
         stop
      endif
      if ( b < 0 ) then
         print *, 'Error :: b less than zero, b = ', b
         stop
      endif
      if ( d < 0 ) then
         print *, 'Error :: d less than zero, d = ', d
         stop
      endif

c     ... vertical positions of cell boundaries
      do k = 1, nz+1
         zbar = dz*(k-1)
         if ( k <= ki+1 ) then
            u  = const_PI*zbar/zibar
            zz = fmin*zbar+ (b*zibar/const_PI)*
     &            (u/2 - sin( 2.0*u )/4.0 )
         elseif ( k <= kf+1 ) then
            zz = zz + dzmin
         else
            dd = zbar - zfbar
            zz = zf + fmin*dd + d*dd*dd*dd/3.0
         endif
         zw(k) = zz
      enddo

c     ... layer mid-points
      do k = nz, 1, -1
         zt(k)  = 0.5*zw(k) + 0.5*zw(k+1)
      enddo

c     ... print them out
      write(*,'("  k     zw     zt    dz")')
      write(*,'(i4,2f7.1)') nz+1, zw(nz+1)
      do k = nz, 1, -1
         write(*,'(i4,3f7.1)') k, zw(k), zt(k), zw(k+1) - zw(k)
      enddo
      write(*,'("  k     zw     zt    dz")')

c     ... prepare files for the UCLA LES input
      open (1,file='zm_grid_in',status='new',form='formatted')
      do k = 1, nz+1
        write(1,'(f7.1)') zw(k)
      end do
      close (1)

      open (2,file='zt_grid_in',status='new',form='formatted')
      zt0 = zt(1) - (zt(2)-zt(1))
      write(2,'(f7.1)') zt0
      do k = 1, nz
        write(2,'(f7.1)') zt(k)
      end do
      close (2)

      end


! Objetivo: Determinar o angulo que resulta no alcance maximo de um projetil
! sujeito a resistencia do ar para k no intervalo de 0 a 0,1.

MODULE arremesso_projetil
	REAL, PARAMETER :: precisao=1.e-5, g=9.8, v0=600.0
	REAL :: k, g_div_k, v0_sin_theta
	LOGICAL :: succes
CONTAINS
	SUBROUTINE funcd(t,altura_funct,deriv_funct)
		USE nrtype
		IMPLICIT none
		REAL, INTENT(IN) :: T
		REAL, INTENT(OUT) :: altura_funct,deriv_funct
		REAL :: exp_menoskt
		exp_menoskt= EXP(-k*T)
		altura_funct=-g_div_k*T+(v0_sin_theta + g_div_k)/k*&
						(1.0-exp_menoskt)
		deriv_funct=-g_div_k+(v0_sin_theta + g_div_k)*exp_menoskt
	END SUBROUTINE funcd
	FUNCTION altura_funct(t)
		USE nrtype
		REAL, INTENT(IN) :: T
		exp_menoskt= EXP(-k*T)
		altura_funct=-g_div_k*t+(v0_sin_theta+g_div_k)/k*&
						(1.0-exp_menoskt)
	END FUNCTION
	FUNCTION alcance(theta)
		USE nrtype
		USE nr, ONLY:rtsafe
		IMPLICIT none
		REAL, INTENT(IN) :: theta
		REAL :: T, t_1, t_2, alcance
		v0_sin_theta=v0*sin(theta)
		g_div_k=g/k
! A funcao altura_funct foi derivada e igualada a zero para encontrar o
! ponto de maximo (t_1, f(t_1)). Desse modo, t_1 eh o ponto de altura maxima
! para qualquer valor de k.
		t_1= REAL(-LOG(g/(k*v0_sin_theta+g))/k)
		t_2= REAL(1.0/k+v0_sin_theta/g)
! Agora T estah entre t_1 e t_2, usando a rtsafe encontramos o valor de T
		T = rtsafe(funcd,t_1,t_2,precisao)
		alcance=-(v0*cos(theta)*(1.0-exp(-k*T))/k)
	END FUNCTION
END MODULE arremesso_projetil
PROGRAM alcance_maximo
	USE arremesso_projetil
	USE nrtype
	USE nr, ONLY: rtsafe, brent
	IMPLICIT none
	REAL :: R,v0_sob_k, R_max
	INTEGER :: contador_ponto
	INTEGER, PARAMETER :: r_theta_vs_k=8,pontos=300,pontos_menos1=pontos-1
	REAL :: theta_inicial=0.0,theta_intermed=0.5*PIO2
	REAL :: theta_final=PIO2,theta_max
	REAL, PARAMETER :: k_inicial=0.0,k_final=0.1
	REAL, PARAMETER :: v0_quad_g=(v0**2)/g
	REAL, PARAMETER :: variacao_k=(k_final-k_inicial)/REAL(pontos_menos1)
	OPEN(unit=r_theta_vs_k,file="R_theta_x_k.dat")
	k=k_inicial
	R_max=v0_quad_g
	theta_max = theta_intermed
	WRITE(unit=r_theta_vs_k,fmt=*) k, R_max, theta_max
	k=k+variacao_k
! Para outros valores de k
	DO contador_ponto=1, pontos_menos1
! Dada a funcao alcance e um trio de abscissas theta_inicial=0.0, theta_intermed
! e theta_final=PIO2 que delimitam um minimo (tal que theta_intermed esta entre
! theta_inicial e theta_final, e o alcance(theta_intermed) eh menor que o
! alcance(0.0) e alcance(PIO2)). A funcao brent calcula o alcance minimo,
! multiplicando por -1 encontramos os valores maximos do alcance.
		R_max = -brent(theta_inicial,theta_intermed,theta_final,alcance,&
							precisao,theta_max)
		WRITE(unit=r_theta_vs_k, fmt=*) k, R_max, theta_max
		k=k+variacao_k
	END DO
	CLOSE(unit=r_theta_vs_k)
END PROGRAM alcance_maximo


! Created by EverLookNeverSee@GitHub on 5/20/20.
! module of constants π , e, and the complex constant i

module constants
    real, parameter :: pi = 3.141593, e = 2.718282
    real, complex :: ci = (0.0, 1.0)
end module constants


PROGRAM stats_5
IMPLICIT NONE
REAL, ALLOCATABLE, DIMENSION(:) :: a
CHARACTER(len=20) :: filename
INTEGER :: i, iptr, j, status
REAL :: median, std_dev, sum_x = 0., sum_x2 = 0., temp, x_bar
CHARACTER(len=80) :: msg
INTEGER :: nvals = 0

WRITE(*, 1000)
1000 FORMAT ('Enter the filename with the data to be sorted:')
READ(*, '(A20)') filename

OPEN(UNIT=9, FILE=filename, STATUS='OLD', ACTION='READ', &
     IOSTAT=status, IOMSG=msg)

fileopen: IF (status == 0) THEN
  DO
    READ(9, *, IOSTAT=status) temp
    IF (status /= 0) EXIT
    nvals = nvals + 1
  END DO

  WRITE(*, '(A,I12)') 'Allocating a: size = ', nvals
  ALLOCATE (a(nvals), STAT=status)

  allocate_ok: IF (status == 0) THEN
    REWIND(UNIT=9)
    READ(9, *) a
    outer: DO i = 1, nvals - 1
      iptr = i
      inner: DO j = i + 1, nvals
        minval: IF (a(j) < a(iptr)) THEN
          iptr = j
        END IF minval
      END DO inner

      swap: IF (i /= iptr) THEN
        temp = a(i)
        a(i) = a(iptr)
        a(iptr) = temp
      END IF swap
    END DO outer

    sums: DO i = 1, nvals
      sum_x = sum_x + a(i)
      sum_x2 = sum_x2 + a(i)**2
    END DO sums

    enough: IF (nvals < 2) THEN
      WRITE(*, *) 'At least 2 values must be entered.'
    ELSE
      x_bar = sum_x / REAL(nvals)
      std_dev = SQRT((REAL(nvals) * sum_x2 - sum_x**2) &
              / (REAL(nvals) * real(nvals - 1)))
      even: IF (MOD(nvals, 2) == 0) THEN
        median = (a(nvals/2) + a(nvals/2+1)) / 2.
      ELSE
        median = a(nvals/2+1)
      END IF even
      WRITE(*, '(A,F8.3)') 'MEAN:    ', x_bar
      WRITE(*, '(A,F8.3)') 'MEDIAN:  ', median
      WRITE(*, '(A,F8.3)') 'STD_DEV: ', std_dev
      WRITE(*, '(A,I8)')   'N:       ', nvals
    END IF enough
    DEALLOCATE(a, STAT=status)
  END IF allocate_ok
ELSE fileopen
  WRITE(*, 1050) TRIM(msg)
  1050 FORMAT ('File open failed. Status: ', A)
END IF fileopen
END PROGRAM stats_5


c         This file contains four two user-callable subroutines:
c         gammanew_eval, gammanew_eval_extend, gammanew_eval_log,
c         gammanew_eval_extend_log. The first calculates the Gamma
c         function of a real argument (either positive or negative)
c         to full double precision. The second calculates the Gamma
c         function of a real argument (either positive or negative)
c         to (almost) full extended precision, provided the variables
c         are re-declared to support such precision.
c
c         The subroutines gammanew_eval_log, gammanew_eval_extend_log
c         are identical to the subroutines gammanew_eval,
c         gammanew_eval_extend, with the exception that instead of the
c         gamma function they return the said function's logarithm.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
        subroutine gammanew_eval_log_extend(x,gam)
        implicit real *8 (a-h,o-z)
        save
c
c        This subroutine evaluates the logarithm of the Gamma function
c        of a real argument; it produces (almost) full extended
c        precision results for both positive and negative values
c        of the argument, provided the variables are re-declared
c        to support such precision.
c
c        PLEASE NOTE THAT IN THE REGIMES WHERE THE GAMMA FUNCTION IS
C        NEGATIVE, THE SUBROUTINE RETURNS THE LOGARITHM OF ITS
C        ABSOLUTE VALUE.
c
c                  Input parameters:
c
c  x - the argument of which the Gamma function is to be computed
c
c                  Output parameters:
c
c  gam - the logarithm of the Gamma function of x (how very appropriate!)
c
c
c       . . . evaluate the logarithm of the Gamma function
c             if the argument is on the interval [1,2]
c
        if( (x .lt. 1) .or. (x.gt. 2) ) goto 2200
c
        call gammanew_eval3_log(x,gam)
        return
c
 2200 continue
c
c
c       ... if x > 2
c
        if(x .lt. 1.5) goto 3200
c
c       find x0 on the interval [1,2] with which we start,
c       and evaluate gamma at it
c
        n=x
        x0=x-n+1
        call gammanew_eval3_log(x0,gam)
c
c       march!
c
        do 2400 i=2,n
c
        gam=gam+log(i+x0-2)
 2400 continue
c
        return
c
 3200 continue
c
c       ... if  0 .leq. x .leq.  1
c
        if(x .lt. 0) goto 4200
c
        x0=x+1
        call gammanew_eval3_log(x0,gam)
        gam=gam-log(x)
        return
c
 4200 continue
c
c       ... if x < 0
c
        x1=-x
        n=x1
        x0=x1-n
        x0=1-x0+1
c
        call gammanew_eval3_log(x0,gam)
c
        xx=x0-1
        do 5200 i=1,n+2
c
        gam=gam-log(abs(xx))
        xx=xx-1
 5200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval_log(x,gam)
        implicit real *8 (a-h,o-z)
        save
c
c        This subroutine evaluates the logarithm of the Gamma function
c        of a real argument; it produces full double precision results
c        for both positive and negative values of the argument.
c
C        PLEASE NOTE THAT IN THE REGIMES WHERE THE GAMMA FUNCTION IS
C        NEGATIVE, THE SUBROUTINE RETURNS THE LOGARITHM OF ITS
C        ABSOLUTE VALUE.
C
c                  Input parameters:
c
c  x - the argument of which the Gamma function is to be computed
c
c                  Output parameters:
c
c  gam - the logarithm of the Gamma function of x (how very appropriate!)
c
c
c       . . . evaluate the logarithm of the Gamma function
c             if the argument is on the interval [1,2]
c
        if( (x .lt. 1) .or. (x.gt. 2) ) goto 2200
c
        call gammanew_eval2_log(x,gam)
        return
c
 2200 continue
c
c
c       ... if x > 2
c
        if(x .lt. 1.5) goto 3200
c
c       find x0 on the interval [1,2] with which we start,
c       and evaluate gamma at it
c
        n=x
        x0=x-n+1
        call gammanew_eval2_log(x0,gam)
c
c       march!
c
        do 2400 i=2,n
c
        gam=gam+log(i+x0-2)
 2400 continue
c
        return
c
 3200 continue
c
c       ... if  0 .leq. x .leq.  1
c
        if(x .lt. 0) goto 4200
c
        x0=x+1
        call gammanew_eval2_log(x0,gam)
        gam=gam-log(x)
        return
c
 4200 continue
c
c       ... if x < 0
c
        x1=-x
        n=x1
        x0=x1-n
        x0=1-x0+1
c
        call prin2('x0=*',x0,1)

        call gammanew_eval2_log(x0,gam)
c
        xx=x0-1
        do 5200 i=1,n+2
c
        gam=gam-log(abs(xx))
        xx=xx-1
 5200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval3_log(x,gam)
        implicit real *8 (a-h,o-z)
        dimension coefs(42)
        data coefs/
     1  -.120782237635245222345518445781646D+00,
     2  0.182449869892882602795118335006149D-01,
     3  0.116850275068084913677155687492027D+00,
     4  -.172665967548816665749236304400537D-01,
     5  0.366950790104801363656336640942244D-02,
     6  -.904752559027923226702063033929312D-03,
     7  0.241179440157020317746429313847828D-03,
     8  -.673640931966506793016607029366479D-04,
     9  0.193973781620149128734637856623748D-04,
     *  -.570502042708584364645567397395294D-05,
     1  0.170413630448254881730170850280867D-05,
     2  -.515095553646304672163231216170731D-06,
     3  0.157154048593298006175111322327474D-06,
     4  -.483119555232553485171697583494630D-07,
     5  0.149457513722498842477000858912645D-07,
     6  -.464831354195249220547668790930112D-08,
     7  0.145232233619810644923193813836471D-08,
     8  -.455578791522056192987778762139738D-09,
     9  0.143413197588172550414382835362441D-09,
     *  -.452865323417441015573380473066286D-10,
     1  0.143403848882077097551112487075603D-10,
     2  -.455243644934763089569345512431042D-11,
     3  0.144848973320723395282144093531243D-11,
     4  -.461834869766318701759601704380834D-12,
     5  0.147530229774684050616043905322468D-12,
     6  -.472095899923600758417333684711329D-13,
     7  0.151310521710013342466880922231033D-13,
     8  -.485686801476166232271748203132829D-14,
     9  0.156144198997796652518964422860473D-14,
     *  -.502544804552392246881299973067650D-15,
     1  0.161580172500207145883271023448381D-15,
     2  -.521114590948289341160665737783119D-16,
     3  0.171382083302691489326179629126128D-16,
     4  -.554748821197081512427887357740726D-17,
     5  0.158673415478853248945912441533215D-17,
     6  -.509788453463554343682988517338423D-18,
     7  0.267137492143822801798879951011477D-18,
     8  -.880385756441013041066119183271692D-19,
     9  -.586092705483764190954532218784502D-20,
     *  0.220231881515274593029003021427310D-20,
     1  0.645061720132042199184763314365149D-20,
     2  -.212720240682484916622372020931097D-20/
c
        save
c
        n=42
        done=1
        gam=0
c
        t=(x-1-done/2)*2
c
        do 1200 i=1,n
c
        gam=gam+coefs(i)*t**(i-1)
cccc        gam=gam+coefs(i)*x**(i-1)
 1200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval2_log(x,gam)
        implicit real *8 (a-h,o-z)
        dimension coefs(22)
c
        data coefs/
     1  -.120782237635245221D+00,0.182449869892882600D-01,
     2  0.116850275068084696D+00,-.172665967548815972D-01,
     3  0.366950790105704649D-02,-.904752559030809163D-03,
     4  0.241179440011251918D-03,-.673640931500792339D-04,
     5  0.193973793625582700D-04,-.570502081063888534D-05,
     6  0.170413056607272862D-05,-.515093720376700298D-06,
     7  0.157171045376283400D-06,-.483173853131163447D-07,
     8  0.149136746086145614D-07,-.463806694457011235D-08,
     9  0.149074784822671166D-08,-.467852246675690637D-09,
     *  0.115448734319838611D-09,-.363558981433883658D-10,
     1  0.252470225044276880D-10,-.803435452853097061D-11/
c
        save
c
        n=22
        done=1
        gam=0
c
        t=(x-1-done/2)*2
c
        do 1200 i=1,n
c
        gam=gam+coefs(i)*t**(i-1)
cccc        gam=gam+coefs(i)*x**(i-1)
 1200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval(x,gam)
        implicit real *8 (a-h,o-z)
        save
c
c        This subroutine evaluates the Gamma function of a real argument;
c        it produces full double precision results for both positive and
c        negative values of the argument.
c
c                  Input parameters:
c
c  x - the argument of which the Gamma function is to be computed
c
c                  Output parameters:
c
c  gam - the Gamma function of x (how very appropriate!)
c
c
c       . . . evaluate the Gamma function if the argument is
c             on the interval [1,2]
c
        if( (x .lt. 1) .or. (x.gt. 2) ) goto 2200
c
        call gammanew_eval2(x,gam)
        return
c
 2200 continue
c
c
c       ... if the x > 2
c
        if(x .lt. 1.5) goto 3200
c
c       find x0 on the interval [1,2] with which we start,
c       and evaluate gamma at it
c
        n=x
        x0=x-n+1
        call gammanew_eval2(x0,gam)
c
c       march!
c
        do 2400 i=2,n
c
        gam=gam*(i+x0-2)
 2400 continue
c
        return
c
 3200 continue
c
c       ... if the 0 .leq. x .leq.  1
c
        if(x .lt. 0) goto 4200
c
        x0=x+1
        call gammanew_eval2(x0,gam)
        gam=gam/x
        return
c
 4200 continue
c
c       ... if x < 0
c
        x1=-x
        n=x1
        x0=x1-n
        x0=1-x0+1
c
        call gammanew_eval2(x0,gam)
c
        xx=x0-1
        do 5200 i=1,n+2
c
        gam=gam/xx
        xx=xx-1
 5200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval_extend(x,gam)
        implicit real *8 (a-h,o-z)
        save
c
c        This subroutine evaluates the Gamma function of a real argument;
c        it produces (almost) full extended precision results for both
c        positive and negative values of the argument, provided the
c        variables are re-declared to support such precision.
c
c                  Input parameters:
c
c  x - the argument of which the Gamma function is to be computed
c
c                  Output parameters:
c
c  gam - the Gamma function of x (how very appropriate!)
c
c
c
c       evaluate the Gamma function if the argument is
c       on the interval [1,2]
c
        if( (x .lt. 1) .or. (x.gt. 2) ) goto 2200
c
        call gammanew_eval3(x,gam)
        return
c
 2200 continue
c
c
c       ... if the x > 2
c
        if(x .lt. 1.5) goto 3200
c
c       find x0 on the interval [1,2] with which we start,
c       and evaluate gamma at it
c
        n=x
        x0=x-n+1
        call gammanew_eval3(x0,gam)
c
c       march!
c
        do 2400 i=2,n
c
        gam=gam*(i+x0-2)
 2400 continue
c
        return
c
 3200 continue
c
c       ... if the 0 .leq. x .leq.  1
c
        if(x .lt. 0) goto 4200
c
        x0=x+1
        call gammanew_eval3(x0,gam)
        gam=gam/x
        return
c
 4200 continue
c
c       ... if x < 0
c
        x1=-x
        n=x1
        x0=x1-n
        x0=1-x0+1
c
        call gammanew_eval3(x0,gam)
c
        xx=x0-1
        do 5200 i=1,n+2
c
        gam=gam/xx
        xx=xx-1
 5200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval3(x,gam)
        implicit real *8 (a-h,o-z)
        dimension coefs(42)
c
        data coefs/
     1  0.886226925452758013649083741670623D+00,
     2  0.161691987244425069144349421339960D-01,
     3  0.103703363422075292057509405775161D+00,
     4  -.134118505705965264609427444590074D-01,
     5  0.904033494028884643989576361780254D-02,
     6  -.242259538437044385764617259435110D-02,
     7  0.915785997143379523502915231849406D-03,
     8  -.296890121522383830093923366409561D-03,
     9  0.100928150217797671460960524521708D-03,
     *  -.336375842059855958365225717995453D-04,
     1  0.112524564378898714084403565633111D-04,
     2  -.375498601769608326351463199728310D-05,
     3  0.125284265183407932726509306293675D-05,
     4  -.417822570478480417873660426799984D-06,
     5  0.139318222887586378078540067572924D-06,
     6  -.464480612525716981485156868788579D-07,
     7  0.154844321007218425984980044056116D-07,
     8  -.516182587481302823323689251947993D-08,
     9  0.172067842623297864468229367955008D-08,
     *  -.573573438914607316487896043927398D-09,
     1  0.191193940645124209184837634463979D-09,
     2  -.637318726733661744876732845701618D-10,
     3  0.212440679157787075404568786925963D-10,
     4  -.708137779578620656802105580438353D-11,
     5  0.236046717483456631493100121338592D-11,
     6  -.786824290629355714996723594265115D-12,
     7  0.262268505662015465618725444423847D-12,
     8  -.874213989908817094617396890755866D-13,
     9  0.291499417333710813797738200069174D-13,
     *  -.971833531575606294591946449847318D-14,
     1  0.322856823583449058974923602843996D-14,
     2  -.107469659233788012193712173282348D-14,
     3  0.367876256573690494365473260918666D-15,
     4  -.123625276708537256683380049874862D-15,
     5  0.347433987117776040343629749755013D-16,
     6  -.110914923764776138469573598500169D-16,
     7  0.686389384962107642842040168449156D-17,
     8  -.245328327855757521477785550619204D-17,
     9  -.251052453492112032869491235353891D-18,
     *  0.118067019426474278738319173650695D-18,
     1  0.182746800335155441155764424855902D-18,
     2  -.642344360403561579751828672744009D-19/
c
        save
c
        n=42
        done=1
        gam=0
c
        t=(x-1-done/2)*2
c
        tt=1
        do 1200 i=1,n
c
        gam=gam+coefs(i)*tt
        tt=tt*t
 1200 continue
c
        return
        end
c
c
c
c
c
        subroutine gammanew_eval2(x,gam)
        implicit real *8 (a-h,o-z)
        dimension coefs(22)
c
        data coefs/
     1  0.886226925452758027D+00,0.161691987244425025D-01,
     2  0.103703363422071934D+00,-.134118505705954070D-01,
     3  0.904033494042846197D-02,-.242259538441698247D-02,
     4  0.915785994891075934D-03,-.296890120771614378D-03,
     5  0.100928168758020265D-03,-.336375903860729251D-04,
     6  0.112523678860543027D-04,-.375495650035445620D-05,
     7  0.125310464830949639D-05,-.417909902825316389D-06,
     8  0.138824572934630909D-06,-.462835109086989667D-07,
     9  0.160743202007499598D-07,-.535845567983428334D-08,
     *  0.129318662203785113D-08,-.431075842242065260D-09,
     1  0.356478271052638709D-09,-.118826785520470270D-09/
        save
c
        n=22
        done=1
        gam=0
c
        t=(x-1-done/2)*2
c
        tt=1
        do 1200 i=1,n
c
        gam=gam+coefs(i)*tt
        tt=tt*t
 1200 continue
c
        return
        end


subroutine DHaj(n, aj)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will compute the weights a_j that are used to
!	expand an equally sampled grid into spherical harmonics by using
!	the sampling theorem presented in Driscoll and Healy (1994).
!
!	Note that the number of samples, n, must be even! Also, a_j(1) = 0
!
!	Calling parameters:
!		IN
!			n	Number of samples in longitude and latitude.
!		OUT
!			aj	Vector of length n containing the weights.
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek (May, 2004)
!
!	Copyright (c) 2005, 2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	n
	real*8, intent(out) ::	aj(:)
	integer ::		j, l
	real*8 ::		sum1, pi

	pi = acos(-1.0d0)

	aj = 0.0d0

	if (mod(n,2) /= 0) then
		print*, "Error --- DH_aj"
		print*, "The number of samples in the equi-dimensional grid must be even for use with SHExpandDH"
		print*, "Input value of N is ", n
		stop
	elseif (size(aj) < n) then
		print*, "Error --- DH_aj"
		print*, "The size of AJ must be greater than or equal to N where N is ", n
		print*, "Input array is dimensioned as ", size(aj)
		stop
	endif

	do j=0, n-1
		sum1 = 0.0d0

		do l=0, n/2 -1
			sum1 = sum1 + sin( dble(2*l+1) * pi * dble(j) / dble(n) ) / dble(2*l+1)
		enddo

		aj(j+1) = sum1  * sin(pi * dble(j)/dble(n)) * sqrt(8.0d0) / dble(n)

	enddo

end subroutine DHaj


! Code by: Jostein Brandshoi

PROGRAM advection_solver
    IMPLICIT NONE
    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    double precision :: upwind_scheme                               ! Function declaration for upwind scheme

    double precision, parameter :: L = 50000.0                      ! Location (L/2) where initial bell is max [m]
    double precision, parameter :: sigma = L / 10.0                 ! Measure of with of initial Gaussian bell [m]
    double precision, parameter :: theta_0 = 10.0                   ! Max temperature value of initial bell [deg C]
    double precision, parameter :: u_0 = 1.0                        ! Advection speed (constant here) [m/s]
    double precision, parameter :: epsilon = 1E-15

    double precision, parameter :: C = 0.50                         ! Courant number [u_0 * delta_t / delta_x] [m/s]
    double precision, parameter :: delta_x = sigma / 10.0           ! Distance between spatial gridpoints [m]
    double precision, parameter :: delta_t = (C * delta_x) / u_0    ! Time between temporal gridpoints [s]
    double precision :: x_j                                         ! Helper variable to increase readability in IC-loop

    integer :: j, n                                                 ! Counter variables (j: space, n: time)
    integer :: n_temp, n_curr = 1, n_next = 2                       ! Indices to represent curr and next time stetp
    integer, parameter :: j_max = idint((L / delta_x) + 1)          ! Max number of space points in [0: j = 1, L: j = j_max]
    integer, parameter :: n_max = idint((25 * L) / (u_0 * delta_t)) ! Max number of time points needed for 25 cycles
    integer, parameter :: n_05c = idint((5 * L) / (u_0 * delta_t))  ! Number of time points needed for 5 cycles
    integer, parameter :: n_10c = idint((10 * L) / (u_0 * delta_t)) ! Number of time points needed for 10 cycles
    integer, parameter :: n_15c = idint((15 * L) / (u_0 * delta_t)) ! Number of time points needed for 15 cycles
    integer, parameter :: n_20c = idint((20 * L) / (u_0 * delta_t)) ! Number of time points needed for 20 cycles

    double precision :: theta_jp2_star, theta_jp1_star, theta_j_star                ! Helper variables for MPDATA method
    double precision :: theta_jm1_star, theta_jm2_star              ! Helper variables for MPDATA method
    double precision :: u_jp1_star, u_j_star, u_jm1_star, F_j_star, F_jm1_star  ! Helper variables for MPDATA method
    double precision, dimension(j_max, 2) :: theta = 0.0            ! 2D-array to store solution at time points n and n + 1

    character(len = 32) :: output_filename                          ! Variable to hold output filename for results
    character(len = 32) :: method_type                              ! String to specify which algorithm to use
    ! -------------------------------------------------------------------------------------

    ! -------- GETTING FILENAME FROM CMD-LINE AND OPEN .DAT FILE FOR RESULT OUTPUT --------
    CALL GET_COMMAND_ARGUMENT(1, output_filename)                ! Get cmd-line arg for output file
    CALL GET_COMMAND_ARGUMENT(2, method_type)                    ! Get cmd-line arg for output file
    open(unit = 10, file = output_filename, form = "formatted")  ! Open file that will store results
    ! -------------------------------------------------------------------------------------

    ! -------------------------------- INITIAL CONDITION ----------------------------------
    do j = 1, j_max                 ! Loop over all space points in the defined region [0, L]
        x_j = (j - 1) * delta_x     ! x-value corresponding to the j'th gridpoint in space
        theta(j, n_curr) = theta_0 * dexp(-((2 * x_j - L) / sigma) ** 2)    ! Initial condition
    end do
    ! -------------------------------------------------------------------------------------

    ! --------------------------- USING UPWIND SCHEME AND BC'S ----------------------------
    do n = 0, n_max     ! Loop, in time as long as necessary to complete requested number of cycles
        theta(1, n_curr) = theta(j_max, n_curr)     ! Cyclic boundary condition (theta(0, t) = theta(L, t))

        do j = 2, j_max ! Loop over all space points in the defined region [0, L]
            theta_j_star = upwind_scheme(theta, j, j - 1, n_curr, j_max, C)  ! Upwind scheme
            F_j_star = 0.0; F_jm1_star = 0.0;   ! Set to zero in case MPDATA is not used

            ! Employ MPDATA method when specified through cmd-line argument
            if (method_type == "mpdata" .and. theta(j, n_curr) > 0) then
                if (j == 2) then
                    theta_jp2_star = upwind_scheme(theta, 4, 3, n_curr, j_max, C)
                    theta_jp1_star = upwind_scheme(theta, 3, 2, n_curr, j_max, C)
                    theta_jm1_star = upwind_scheme(theta, 1, j_max, n_curr, j_max, C)
                    theta_jm2_star = upwind_scheme(theta, j_max, j_max - 1, n_curr, j_max, C)
                else if (j == 3) then
                    theta_jp2_star = upwind_scheme(theta, 5, 4, n_curr, j_max, C)
                    theta_jp1_star = upwind_scheme(theta, 4, 3, n_curr, j_max, C)
                    theta_jm1_star = upwind_scheme(theta, 2, 1, n_curr, j_max, C)
                    theta_jm2_star = upwind_scheme(theta, 1, j_max, n_curr, j_max, C)
                else if (j == j_max) then
                    theta_jp2_star = upwind_scheme(theta, 2, 1, n_curr, j_max, C)
                    theta_jp1_star = upwind_scheme(theta, 1, j_max, n_curr, j_max, C)
                    theta_jm1_star = upwind_scheme(theta, j_max - 1, j_max - 2, n_curr, j_max, C)
                    theta_jm2_star = upwind_scheme(theta, j_max - 2, j_max - 3, n_curr, j_max, C)
                else
                    theta_jp2_star = upwind_scheme(theta, j + 2, j + 1, n_curr, j_max, C)
                    theta_jp1_star = upwind_scheme(theta, j + 1, j, n_curr, j_max, C)
                    theta_jm1_star = upwind_scheme(theta, j - 1, j - 2, n_curr, j_max, C)
                    theta_jm2_star = upwind_scheme(theta, j - 2, j - 3, n_curr, j_max, C)
                end if

                u_jp1_star = 0.25 * (1 - C) * u_0 * ((theta_jp2_star - theta_j_star) / (theta_jp1_star + epsilon))
                u_j_star = 0.25 * (1 - C) * u_0 * ((theta_jp1_star - theta_jm1_star) / (theta_j_star + epsilon))
                u_jm1_star = 0.25 * (1 - C) * u_0 * ((theta_j_star - theta_jm2_star) / (theta_jm1_star + epsilon))

                F_j_star = 0.5 * ((u_j_star + dabs(u_j_star)) * theta_j_star + (u_jp1_star - &
                    dabs(u_jp1_star)) * theta_jp1_star) * (delta_t / delta_x)
                F_jm1_star = 0.5 * ((u_jm1_star + dabs(u_jm1_star)) * theta_jm1_star + &
                    (u_j_star - dabs(u_j_star)) * theta_j_star) * (delta_t / delta_x)
            end if

            theta(j, n_next) = theta_j_star - (F_j_star - F_jm1_star)
        end do

        ! Write theta to file for time steps corresponding to the requested cycles.
        if (n == 0 .or. n == n_05c .or. n == n_10c .or. n == n_15c .or. n == n_20c .or. n == n_max) then
            write(unit = 10, fmt = "(102f20.14)") float(n), theta(:, n_curr) / theta_0  ! Write line-wise
        end if

        n_temp = n_next     ! Set help index to second theta column (2)
        n_next = n_curr     ! Set next time step index to first theta column (1)
        n_curr = n_temp     ! Set current time step index to second column (2)
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = 10)    ! Close file after writing

END PROGRAM advection_solver

double precision function upwind_scheme(theta, j, jm1, n_curr, j_max, C)
    double precision, dimension (j_max, 2) :: theta  ! 2D theta array
    double precision C                               ! Courant number
    integer j, jm1                                   ! j'th and (j - 1)'th point

    upwind_scheme = theta(j, n_curr) - C * (theta(j, n_curr) - theta(jm1, n_curr)) ! Upwind scheme
    return
end


program seriallaplace
  implicit none
  integer, parameter :: n=200
  real(8), dimension(0:n+1, 0:n+1) :: u
  real(8), dimension(1:n, 1:n) :: unew
  real(8) :: error
  integer :: iter, i, j

  u = 0.0d0
  unew = 0.0d0
  u(:,n+1) = 10.0d0
  error = 1000.0d0
  iter = 0

  do while ( error > 1.0d-6 .and. iter < 1000)

     do j = 1,n
        do i = 1,n
           unew(i,j) = 0.25d0*(  u(i+1,j) + u(i-1,j) + u(i,j+1) + u(i,j-1) )
        end do
     end do

     error = 0.0d0

     do j = 1,n
        do i = 1,n
           error = error + abs(unew(i,j)-u(i,j))
           u(i,j) = unew(i,j)
        end do
     end do

     iter = iter+1

     if (mod(iter,100) == 0) then
        write(*, *) "Iteration ",iter,", error = ",error
     end if
  end do

end program seriallaplace


PROGRAM grav_force
IMPLICIT NONE
  REAL :: calc_grav
  WRITE(*, *) calc_grav(5.98E24, 1000., 38000000.)

END PROGRAM grav_force

REAL FUNCTION calc_grav(m1, m2, r)
IMPLICIT NONE
  REAL, INTENT(IN) :: m1, m2, r
  REAL, PARAMETER :: G = 6.672E-11
  calc_grav = (G * m1 * m2) / r**2
END FUNCTION calc_grav