      subroutine DILUP (X, Y, NTAB, XT, YT, NDEG, LUP, IOPT, EOPT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2010-08-26 DILUP  Krogh  Dimension of IDAT increased to 4.
c>> 2010-03-05 DILUP  Krogh  Added more checks for NDEG too big.
c>> 2010-03-03 DILUP  Krogh  Fixed bug in flagging extrpolation.
c>> 2006-05-11 DILUP  Krogh  No flag of extrapolation on equality.
c>> 2006-04-01 DILUP  Krogh  Fixed minor bug just introduced.
c>> 2006-03-31 DILUP  Krogh  Don't flag extrap. when on end point.
c>> 2003-04-17 DILUP  Krogh  Fixed bugs in derivatives with vectors.
c>> 2000-12-03 DILUP  Krogh  Fixed so no reference to YT when LEXIT=0.
c>> 2000-12-01 DILUP  Krogh  Removed unused parameter MENTXT.
c>> 1998-01-26 DILUP  Krogh  Extrap. due to too many bad pts. flagged.
c>> 1997-09-30 DILUP  Krogh  Decremented NDEGI when LUP=4 & GETERR.
c>> 1996-04-08 DILUP  Krogh  With LUP=4 & GETERR, NDEGI was 1 too small.
c>> 1996-03-30 DILUP  Krogh  Added external statement.
C>> 1995-12-01 DILUP  Krogh  Fixed bugs connected with option 6.
C>> 1995-11-10 DILUP  Krogh  Fixed so char. data at col. 72 is not ' '.
C>> 1995-03-03 DILUP  Krogh  Bug in last change made DILUPM fail.
C>> 1994-12-22 DILUP  Krogh  Added Hermite interpolation.
C>> 1994-11-11 DILUP  Krogh  Declared all vars.
c>> 1994-10-20 DILUP  Krogh  Changes to use M77CON
c>> 1994-09-12 DILUP  Krogh  Added CHGTYP code.
c>> 1993-04-28 DILUP  Krogh  Additions for Conversion to C.
c>> 1992-05-27 DILUP  Krogh  Fixed bug in error estimate.
c>> 1992-04-08 DILUP  Krogh  Removed unused labels 510 and 2080.
c>> 1991-10-17 DILUP  Krogh  Initial Code.
c
c--D replaces "?": ?ILUP, ?ILUPM, C?ILUP, ?MESS
c
c Polynomial Interpolation with look up.
c Design/Code by  Fred T. Krogh, Jet Propulsion Laboratory, Pasadena, CA
c
c In addition to doing standard 1 dimensional interpolation, this
c subroutine supports efficient interpolation of several functions
c defined at the same values of the independent variable and supports
c DILUPM, a subroutine for doing multidimensional interpolation.  Error
c estimates, Hermite interpolation, and derivatives of the interpolant
c can be obtained via options.
c Algorithms used are described in "Efficient Algorithms for Polynomial
c Interpolation and Numerical Differentiation", by Fred T. Krogh, Math.
c of Comp. Vol. 24, #109 (Jan. 1970), pp. 185-190.
c
c     *************     Formal Arguments     ***************************
c
c X      Independent variable where value of interpolant is desired.
c Y      Value of interpolant, computed by this subroutine.  The
c        interpolant is always a piecewise polynomial.
c NTAB   Number of points in the table.
c XT     Array of independent variable values.  Must be monotone
c        increasing or monotone decreasing.  If XT(I) = XT(I+1) for some
c        I, then the XT(J)'s that are used in the interpolation will
c        either have all J's .le. I, or all J's .ge. I+1.  If the XT's
c        are equally spaced an option allows one to provide only XT(1),
c        and the increment between the XT's.
c YT     Array of dependent variable values.  Y(XT(I)) = YT(I).
c NDEG   If NDEG < 2 or odd, then it gives the degree of the polynomial
c        used.  Else the polynomial used is a linear combination of two
c        polynomials of degree NDEG, such that the resulting polynomial
c        is of degree NDEG+1 and has a continuous first derivative.
c        Typically accuracy will improve as NDEG increases up to some
c        point where it will start to get worse because of either
c        rounding errors or the inherant instability of high degree
c        polynoimial interpolation. If more than MAXDEG-th degree is
c        desired, parameter MAXDEG must be changed below.  It is
c        currently 15.  If X is so close to the end of the table that
c        the same number of points can not be selected on both sides of
c        x the degree of the interpolant is NDEG exactly.  When
c        extrapolating, the degree used is max(2, 2*(NDEG/2)), where the
c        divide is truncated to the nearest integer.
c LUP    Defines the type of look up method.  (Changed if LUP < 1.)
c    < 0   Use a sequential search starting with an index of -LUP, and
c          set LUP to -k on exit where k minimizes abs(X-XT(k)).
c    = 0   As for < 0, except start with a binary search.
c    = 1   Use a binary search.
c    = 2   Start a sequential search with an index = [1.5 +
c          (NTAB-1) * (X-XT(1)) / (XT(NTAB)-XT(1))].
c    = 3   YT(k) corresponds to XT(1) + (k-1)*XT(2), no search is needed
c          to do the look up and XT can have dimension 2.
c    = 4   Internal information connected with X-XT(k) values used in
c          in the last interpolation is reused.  (Only use if there are
c          no intervening calls to DILUP.)  No options should be
c          specified and only YT should be different.  Intended for
c          interpolating components after the first of a vector valued
c          function.
c IOPT   IOPT(1) is used to return a status as follows.
c    -10   An option index is out of range.
c    -9    NTAB is outside of allowed limits.
c    -8    NDEG is outside of allowed limits.
c    -7    LUP > 3 (use old parameters), used when not ready for it.
c    -6    Option 3 (compute derivatives), has requested more than
c          MAXDEG derivatives.
c    -5    LUP = 3 and XT(2) = 0.
c    -4    XT(1) = XT(NTAB), and NTAB is not 1.
c    -3    < 2 points available because of bad points.
c    -2    Only one table entry available, req. err. est. not computed.
c    -1    The accuracy requested was not obtained.
c     0    Nothing special to flag.
c     1    X was outside the domain of the table, extrapolation used.
c     2    NTAB is so small, it restricted the degree of the polynomial.
c
c        Starting with IOPT(2) options are specified by integers in the
c        range 0-6, followed in some cases by integers providing
c        argument(s).  Each option, together with its options its
c        arguments if any is followed in IOPT by the next option (or 0).
c     0    No more options; this must be last in the option list.
c     1    An error estimate is to be returned in EOPT(1).
c     2    (Argument: K2)  K2 gives the polynomial degree to use when
c          extrapolating.
c     3    (Argument: K3, L3) Save (k-th derivative of interpolating
c          polynomial) / (k!) in EOPT(K3+K-1) for k = 1, 2, ..., L3.
c          These values are the coefficients of the polynomial in the
c          monomial basis expanded about X.  One must have 0<L3<NDEG+1.
c     4    (Argument K4) The absolute and relative errors expected in
c          YT entries are specified in EOPT(K4) and EOPT(K4+1)
c          respectively.  The values provided here are used in
c          estimating the error in the interpolation which is stored
c          in EOPT(1).
c     5    (Argument K5, L5) Do the interpolation to the accuracy
c          requested by the absolute error tolerance specified in
c          EOPT(K5) and the relative error tolerance in EOPT(K5+1)
c          respectively.  An attempt is made to keep the final error
c          < EOPT(K5) + EOPT(K5+1) * (abs(YT(i1) +abs(YT(i2)), where
c          i1 and i2 are indices for table values close to X.
c          Interpolation is done as for the default case, except that
c          in this case NDEG gives the maximal degree polynomial to use
c          in the interpolation, and polynomial interpolation of even
c          degree can happen.  (The form that gives the C1 continuity
c          is not available in this case, and in fact continuity of the
c          interpolant itself is not to be expected.  The actual degree
c          used in doing the interpolation is stored in the space for
c          the argument L5.  An error estimate is returned in EOPT(1).
c     6    (Argument K6) Do not use point k in the interpolation if
c          YT(k) = EOPT(K6).
c     7    (Argument K7) YT(K7+i) gives the first derivative
c          corresponding to the function value in YT(i).  These
c          derivatives are to be used in doing the interpolation.  One
c          gets a continuous interpolant only for NDEG = 3, 7, 11, and
c          15.  The interpolating polynomial satisfies p(XT(i)) = YT(i),
c          p'(XT(i)) = YT(K7+i) for values of i that give values of XT
c          close to X.  (Subject to keeping within one of the same
c          number of XT's on either side of X, the maximum of |XT(i)-X|
c          is minimized.)  If NDEG is even a value of YT(i) is used
c          without using the corresponding value of YT(K7+i).
c  >253    Used for calls from DILUPM, a number of variables in the
c          common block have been set.  If this is used, it must be the
c          first option, and common variables must be set.  The rest
c          of IOPT is not examined for options.
c EOPT   Array used to return an error estimate and also used for
c        options.
c     EOPT(1)  if an error estimate is returned, this contains a crude
c              estimate of the error in the interpolation.
c
c      ************     External Procedures      ***********************
c
c D1MACH Returns system parameters.
c DMESS  Prints error messages.
c
c      ************     Variables referenced     ***********************
c
c ADJSAV Saved difference of XT values used to adjust error estimate on
c  variable order when derivatives are being computed.
c BADPT  In common CDILUP.  YT(K) is not to be used if YT(K) = BADPT,
c        and LBADPT = .true.
c CY     Array giving the YT values used to construct the interpolant.
c  Also used to store divided differences.
c D1MACH Function to get parameters of floating point arithmetic.
c DMESS  Program calling MESS to print error messages.
c DX     Array giving the differences X - XT(I), where I runs through
c  the points that are used in the interpolation.
c DXS    Saved value of DX when computing derivatives
c E1     Error estimate from one iteration ago (for variable order)
c E2     Error estimate from this iteration (for variable order)
c E2L    Used in computing error estimate for variable order.
c EBND   If estimated error is < EBND then order is suff. high.
c EBNDI  Internal value for bounding error.
c EBNDR  Used in getting part of EBND due to relative accuracy request.
c EF     Factor used in estimating errors for variable order.
c EN     Used in computing error estimate for variable order.
c EOPT   Formal argument, see above.
c EPSR   Relative error level (D1MACH(4)).
c ERRDAT Holds floating point data for error messages.
c ERREST Estimate of the error in the interpolation.
c GETERR Logical variable that is .true. if we are getting an error est.
c H      In indexed lookup contains the difference between XT values.
c I      Temporary index.
c IO     Index used in processing options.
c IDX    In common CDILUP.  Gives indices of points selected for the
c        interpolation in order selected.
c IIFLG  Internal value for IOPT(1).
c ILI    Lower (sometimes upper) bound on the XT indices that will be
c  used in the interpolation.
c INDXED Logical variable that is .true. if we have an indexed XT.
c IOPT   Formal argument, see above.
c IUI    As for ILI, except an upper (sometimes lower) bound.
c K      Index usually into YT and XT, into CY for derivatives.
c KAOS   In common CDILUP.  Keeps track of state on variable order.
c    = 0   No variable order -- this value only set in DILUPM.
c    = 1   First time
c    = 2   Second time
c    = 3   Just had an increase or a very weak decrease in the error.
c    = 4   Just had a strong decrease in the error.
c   On an error with IIFLG .lt. 0, this is set to -10 * stop level -
c   the print level.
c KDER   0 if not doing Hermite interpolation, else is < 0 if have next
c  higher order difference computed (in TP3), > 0 if it isn't.
c KEXTRP In common CDILUP.  Gives degree to use when extrapolating.
c KGO    Indicates type of interpolation as follows:
c    1     Standard polynomial interpolation.
c    2     Get error estimate after 1.
c    3     Compute an interpolant with some desired accuracy.
c    4     Compute an interpolant with a continuous derivative.
c  >10     Same as if KGO were 10 smaller, except XT values have already
c          been selected.
c KGOC   In common CDILUP.  Value saved for -KGO.  If YT contains values
c        of Y computed elsewhere in the order specified in IDX, then
c        KGOC should be set to abs(KGOC) before calling DILUP.  If -2,
c        an extra value was computed for an error estimate.
c KK     Used in selecting data points to use.
c     1  decrease ILI only
c     0  increase IUI
c    -1  decrease ILI
c   <-1, increase IUI only
c L      Temporary index used in searching the XT array.  Also one less
c  than the number of points used in the current interpolant.
c LBADPT Logical variable set = .true. if checking for bad points.
c LDER   Offset of y' values from the y values.
c LDERIV In common CDILUP. Loc. where first deriv. is stored in EOPT().
c LEXERR In common CDILUP. Loc. where absolute and relative error
c        information on Y is stored in EOPT.
c LEXIT  In common CDILUP.  Defines action after finding location in XT.
c    0     Don't compute anything for Y, just return. (Used for DILUPM.)
c    1     Usual case, just interpolate.
c   >1     Compute LEXIT-1 derivatives of the interpolant.
c LINC   Logical variable used in the sequential search.  Set .true. if
c  the values in XT are increasing with I, and set .false. otherwise.
c LNDEG  Location in IOPT to save degree when variable order is used.
c LOPT   Index of the last option.
c LUP    Formal argument, see above.
c MACT   Array used for error message actions, see DMESS for details.
c MACTV  Array used for part of error message for IOPT.
c MAXDEG Parameter giving the maximum degree polynomial interpolation
c  supported.  MAXDEG must be odd and > 2.
c MESS   Message program called from DMESS to print error messages.
c MEEMES Parameter giving value for printing an error message in MESS.
c MEIVEC Parameter giving value for printing an integer vector in MESS.
c MEMDA1 Parameter giving value for indicating value in MACT for MESS.
c MEMDA2 Parameter giving value for indicating value in MACT for MESS.
c MEMDAT Parameter giving value for specifying MACT index for MESS.
c MERET  Parameter giving value to indicate no more actions for MESS.
c METEXT Parameter giving value to tell MESS to print from MTXTAA.
c LTXTxx Parameter names of this form were generated by PMESS in making
c        up text for error messages and are used to locate various parts
c        of the message.
c MLOC   Array giving starting loctions for error message text.
c MTXTAA Character array holding error message text for MESS.
c N      Used in logic for deciding bounds.  If N = 0, ILI can not be
c  reduced further.  If N = 3*NTABI, IUI can not be increased further.
c NDEG   Formal argument, see above.
c NDEGE  Degree of polynomial to be used.  Starts out = NDEG.
c NDEGEC In common CDILUP.  Degree actually used, saved in common.
c NDEGI  Degree of polynomial up to which y & differences are computed.
c NDEGQ  Used when KGO > 10.  In this case If L .ge. NDEGQ special
c        action is needed.  (Usually means quitting.)
c NTAB   Formal argument, see above.
c NTABI  Internal value of NTAB, = number of points in XT and YT.
c PI     Array use to store interpolation coefficients
c PID    Temporary storage used when computing derivatives.
c SAVED  Logical variable set = .true. if a DX value needs to be
c  replaced and restored when computing derivatives.
c TP1    Used for temporary accumulation of values and temp. storage.
c TP2    Used for temporary storage.
c TP3    Used for divided difference when doing Hermite interpolation.
c X      Formal argument, see above.
c XI     Internal value for X, the place where interpolation is desired.
c XL     Value of "left hand" X when selecting indexed points.
c XT     Formal argument, see above.
c XU     Value of "right hand" X when selecting indexed points.
c Y      Formal argument, see above.
c YL     Last value of Y when selecting the order.
c YT     Formal argument, see above.
c YTORD  Logical variable set .true. when YT values are ordered on entry
c
c     *************     Formal Variable Declarations     ***************
c
      external         D1MACH
      integer          IOPT(*), LUP, NDEG, NTAB
      double precision X, XT(*), Y, YT(*), EOPT(*)
c
c     *************     Common Block and Parameter     *****************
c
c                               MAXDEG must be odd and > 2.
      integer MAXDEG
      parameter (MAXDEG = 15)
c
      logical          GETERR
      integer          KAOS, KEXTRP, KGOC,LDERIV,LEXERR,LEXIT,NDEGEC,
     1                 IDX(0:MAXDEG+1)
      double precision BADPT, DX(0:MAXDEG+1), EBND, EBNDR
      common / CDILUP / BADPT, DX, EBND, EBNDR, KAOS, KEXTRP, KGOC,
     1                  LDERIV, LEXERR,LEXIT,NDEGEC,IDX,GETERR
c
c     *************     Local Variables     ****************************
c
      logical          INDXED, LBADPT, LINC, YTORD, SAVED
      integer          I, IIFLG, ILI, IUI, IO, K, KDER, KGO, KK, L,
     1                LDER, LNDEG, LOPT, N, NDEGE, NDEGI, NDEGQ, NTABI
      double precision ADJSAV, CY(0:MAXDEG+1), DXS, E1, E2, E2L, EBNDI,
     1                 EF, EM, EPSR, ERREST, H, PI(0:MAXDEG+1),
     2                 PID(0:MAXDEG), TP1, TP2, TP3, XI, XL, XU, YL
      double precision D1MACH
      save             EPSR, /CDILUP/
c
c ************************ Error Message Stuff and Data ****************
c
c Parameter defined below are all defined in the error message program
c DMESS.
c
      integer MECONT,MEMDA1,MERET,MEEMES,METEXT,MEIVEC
      parameter (MEMDA1 =27)
      parameter (MECONT = 50)
      parameter (MERET =51)
      parameter (MEEMES =52)
      parameter (METEXT =53)
      parameter (MEIVEC =57)
c
      double precision ERRDAT(2)
      integer MLOC(9), IDAT(4), MACT(5), MACTV(6)

c ********* Error message text ***************
c[Last 2 letters of Param. name]  [Text generating message.]
cAA DILUP$B
cAB Estimated error = $F, Requested error = $F.$E
cAC NTAB = 1, no error estimate computed.$E
cAD Too many bad points, only $I point(s) available.$E
cAE XT(1) = XT(NTAB=$I) = $F ??$E
cAF LUP = 3, and XT(2) = 0.$E
cAG Order of requested derivative, $I, is > bound of $I.$E
cAH LUP > 3, with unprepared common block.$E
cAI NDEG = $I must be .le. $I or  NTAB = $I must be at $C
c   least $I.  You must either decrease NDEG, increase NTAB, $C
c   or if requesting an error estimate, turn off that request.$E
cAJ NDEG = $I is not in the allowed interval of [0, $I].$E
cAK NTAB = $I is not in the allowed interval of [1, $I].$E
cAL IOPT($I) = $I is not a valid option.$E
c   $
cAM IOPT(1:$M): $E
      integer LTXTAA,LTXTAB,LTXTAC,LTXTAD,LTXTAE,LTXTAF,LTXTAG,LTXTAH,
     * LTXTAI,LTXTAJ,LTXTAK,LTXTAL,LTXTAM
      parameter (LTXTAA=  1,LTXTAB=  8,LTXTAC= 53,LTXTAD= 92,LTXTAE=142,
     * LTXTAF=171,LTXTAG=196,LTXTAH=250,LTXTAI=290,LTXTAJ=458,
     * LTXTAK=512,LTXTAL=566,LTXTAM=  1)
      character MTXTAA(3) * (201)
      character MTXTAB(1) * (14)
      data MTXTAA/'DILUP$BEstimated error = $F, Requested error = $F.$EN
     *TAB = 1, no error estimate computed.$EToo many bad points, only $I
     * point(s) available.$EXT(1) = XT(NTAB=$I) = $F ??$ELUP = 3, and XT
     *(2) = 0.$EOrder ','of requested derivative, $I, is > bound of $I.$
     *ELUP > 3, with unprepared common block.$ENDEG = $I must be .le. $I
     * or  NTAB = $I must be at least $I.  You must either decrease NDEG
     *, increase NTAB, or if',' requesting an error estimate, turn off t
     *hat request.$ENDEG = $I is not in the allowed interval of [0, $I].
     *$ENTAB = $I is not in the allowed interval of [1, $I].$EIOPT($I) =
     * $I is not a valid option.$E'/
      data MTXTAB/'IOPT(1:$M): $E'/
c **** End of automatically generated text
c
c                      1 2 3 4      5
      data MACT / MEEMES,0,0,0, MECONT /
c                        2        3      4   5     6
      data MACTV /MEMDA1, 0, METEXT, MEIVEC, 0, MERET /

c
      data MLOC / LTXTAB, LTXTAC, LTXTAD, LTXTAE, LTXTAF, LTXTAG,
     1            LTXTAH, LTXTAI, LTXTAJ /
c
      data EPSR / 0.D0 /
c
c
c      ************     Start of executable code     *******************
c
      IIFLG = 0
      KDER = 0
      PI(0) = 1.D0
      LBADPT = .false.
      ILI = -LUP
      if (ILI .le. -4) go to 1400
      LEXERR = 0
      NTABI = NTAB
      if ((NTABI .le. 0) .or. (NTABI .gt. 9999999)) then
         IIFLG = -9
         IDAT(1) = NTABI
         IDAT(2) = 9999999
         go to 2120
      end if
      NDEGI = NDEG
      NDEGE = NDEGI
      XI = X
      KGO = 1
      IO = 1
      if (IOPT(2) .ge. 254) then
         LBADPT = IOPT(2) .eq. 255
         if (KAOS .le. 0) go to 50
         LNDEG = 0
         KGO = 3
         KAOS = 1
         NDEGI = min(MAXDEG, IOPT(3)+1)
         NDEGE = -NDEGI
         go to 60
      end if
      GETERR = .false.
      KEXTRP = -1
      LEXIT = 1
c                                      Loop to take care of options
   10 IO = IO + 1
      LOPT = IOPT(IO)
      if (LOPT .ne. 0) then
        go to (1930, 1500, 1600, 1900, 1950, 1970, 1980), LOPT
        IIFLG = -10
        IDAT(1) = IO
        IDAT(2) = LOPT
        go to 2120
      end if
   50 continue
      K = NDEGI + 1
      if (KDER .ne. 0) then
        K = K / 2
      else if (mod(NDEGI,2) .eq. 0) then
        K = K + 1
      end if
      if (GETERR) K = K + 1
      if ((NDEGI.lt.0) .or. (NDEGI.gt.MAXDEG) .or. (K.gt.NTAB)) then
         IIFLG = -8
         IDAT(1) = NDEGI
         IDAT(2) = MAXDEG
         IDAT(3) = NTAB
         IDAT(4) = K
         go to 2120
      end if
      if (KGO .eq. 1) then
         if (NDEGI .ge. 2) then
            if (mod(NDEGI, 2) .eq. 0) then
               if (KDER .eq. 0) then
                  NDEGE = NDEGE + 1
                  KGO = 4
               end if
            end if
         end if
      end if
   60 if (KEXTRP .lt. 0) then
         KEXTRP = max(NDEGE-1, min(NDEGE, 2))
         if (KEXTRP .lt. 0) KEXTRP = NDEGI
      end if
      if (ILI .gt. 0) go to 200
      if (ILI + 2) 1300, 1200, 100
c
c                                      Binary search, then sequential
  100    continue
c                         In binary search XT(ILI) .le. XI .le.  XT(IUI)
c                         or we are extrapolating
            ILI = 1
            IUI = NTABI
            if (XT(NTABI) - XT(1)) 110, 1220, 130
  110       ILI = NTABI
            L = 1
  120       IUI = L
  130       L = (IUI - ILI) / 2
            if (L .eq. 0) go to 210
            L = ILI + L
            if (XT(L) .gt. XI) go to 120
            ILI = L
            go to 130
c
c                                      Sequential search, then exit
  200    continue
            if (ILI .gt. NTABI) go to 100
            if (XT(NTABI) .eq. XT(1)) go to 1220
  210       INDXED = .false.
            LINC = XT(NTABI) .gt. XT(1)
            if ((XT(ILI) .gt. XI) .eqv. LINC) go to 230
  220       if (ILI .eq. NTABI) go to 1230
            ILI = ILI + 1
            if ((XT(ILI) .lt. XI) .eqv. LINC) go to 220
            N = 2*ILI
            if (abs(XT(ILI-1)-XI) .lt. abs(XT(ILI) - XI)) then
               ILI = ILI - 1
               N = N - 1
            end if
            go to 240
  230       if (ILI .eq. 1) go to 1230
            ILI = ILI - 1
            if ((XT(ILI) .gt. XI) .eqv. LINC) go to 230
            N = 2*ILI + 1
            if (abs(XT(ILI+1)-XI) .lt. abs(XT(ILI) - XI)) then
               ILI = ILI + 1
               N = N + 1
            end if
  240       if (LUP .le. 0) LUP = -ILI
  250       DX(0) = XI - XT(ILI)
c                                  Get bounding indices and interpolate
  260       IUI = ILI
            K = ILI
            L = -1
            if (LEXIT .eq. 0) then
               NDEGI = 0
               if (GETERR) then
                  if (KGO .ne. 3) then
                     if (KGO .eq. 1) NDEGE = NDEGE + 1
                     KEXTRP = min(KEXTRP+1, NDEGE)
                  else
                     NDEGE = -NDEGE
                  end if
               end if
            end if
c                                  Just got index for next XT
  270       if (LEXIT .eq. 0) then
               L = L + 1
               IDX(L) = K
               go to 350
            end if
            TP2 = YT(K)
            if (LBADPT) then
c                                  Check if point should be discarded
               if (TP2 .eq. BADPT) then
                  if (IUI .ne. ILI) then
                     if (abs(KK) .eq. 1) then
                        N = N - 1
                     else
                        N = N + 1
                     end if
                  end if
                  go to 1020
               end if
            end if
  280       L = L + 1
            IDX(L) = K
c
  290       if (KDER .ne. 0) then
c                           Hermite interpolation
               KDER = -KDER
               if (KDER .lt. 0) then
                  TP3 = YT(LDER + K)
                  if (L .eq. 0) then
                     TP1 = TP2
                  else
                     do 300 I = 1, L
                        TP2 = (TP2 - CY(I-1)) / (DX(I-1) - DX(L))
                        TP3 = (TP3 - TP2) / (DX(I-1) - DX(L))
  300                continue
                     PI(L) = PI(L-1) * DX(L-1)
                     TP1 = TP1 + PI(L) * TP2
                  end if
               else
                  DX(L) = DX(L-1)
                  PI(L) = PI(L-1) * DX(L)
                  TP2 = TP3
                  TP1 = TP1 + PI(L) * TP2
               end if
            else if (L .eq. 0) then
                  TP1 = TP2
            else
               PI(L) = PI(L-1) * DX(L-1)
               if (L .le. NDEGI) then
c                                 Get divided differences & interpolate.
                  do 320 I = 1, L
                     TP2 = (TP2 - CY(I-1)) / (DX(I-1) - DX(L))
  320             continue
                  TP1 = TP1 + PI(L) * TP2
               end if
            end if
            CY(L) = TP2
  350       if (L .lt. NDEGE) go to 1000
  360       if (LEXIT .eq. 0) go to 2110
            go to (500, 600, 900, 800), KGO
            if (L .ge. NDEGQ) go to (500,600,900,800), KGO-10
c                        Already got the points selected.
  400       L = L + 1
            if (YTORD) then
               TP2 = YT(L+1)
            else
               K = IDX(L)
               TP2 = YT(K)
            end if
            go to 290
c Got simple interpolated value.
  500       Y = TP1
            if (.not. GETERR) go to  2000
            NDEGI = NDEGI + 1
            KGO = KGO + 1
            if (NDEGE .ge. 0) go to 1000
            go to 400
c Got info. for error estimate.
  600       if (L .eq. 0) then
               IIFLG = -2
            else
               ERREST=1.5D0*(abs(TP1-Y)+.03125D0*abs(PI(L-1)*CY(L-1)))
               L = L - 1
            end if
            go to  2000
c C1 interpolant.
  800       do 810 I = 1, L-1
               TP2 = (TP2 - CY(I-1)) / (DX(I-1) - DX(L))
  810       continue
            TP2 = (TP2 - CY(L-1)) / (DX(0) - DX(1))
            CY(L) = TP2
            PI(L) = PI(L-1) * DX(0)
            Y = TP1 + PI(L) * TP2
            if (GETERR) ERREST = 1.5D0 * abs(PI(L-1)) * abs(((DX(L-1) *
     1         (DX(0) - DX(1)) / (DX(L-1) - DX(L)) - DX(0)) * TP2) +
     2         abs(.03125D0*CY(L-1)))
            go to 2000
c    Variable order, check estimated error and convergence.
  900       continue
            if (KAOS .ge. 3) go to 930
            if (KAOS .eq. 2) go to 920
c                                        First time
            if ((KDER.ne.0) .and. (LEXIT.gt.1) .and. (L.eq.0)) go to 970
            KAOS = 2
            E2L = abs(TP1)
            E2 = EBND + 1.D30
            go to 970
c                                        Second time
  920       KAOS = 4
            EBNDI = .66666D0*(EBND + EBNDR*(abs(CY(0))+abs(YT(IDX(1)))))
            EF = DX(0)
            if (LEXIT .gt. 1) then
               EF = DX(L) - DX(0)
               ADJSAV = EF
            end if
            E2 = abs(EF * TP2)
            EM = .75D0
            go to 950
c                                        Usual case
  930       E2L = E2
            E1 = E2L * (5.D0 * EM / dble(L))
            EF = EF * DX(L-1)
            E2 = abs(EF*TP2)
            EM = 0.5D0 * EM + E2 / (E2L + E2 + 1.D-20)
            if (E2 .ge. E1) then
               if (KAOS .eq. 3) then
c                          Apparently diverging, so quit.
                  L = L - 1
                  go to 960
               else
                  KAOS = 3
               end if
            else
               KAOS = 4
            end if
  950       YL = TP1
            if (E2L + E2 .gt. EBNDI) then
               if ((L+NDEGE .lt. 0) .and. (IIFLG .ne. 2)) go to 970
               if (KGO .eq. 13) then
c                                 May need early exit to get next point.
                  IOPT(2) = 0
                  if (L .lt. NDEG) go to 2110
               end if
            end if
  960       TP2 = 1.5D0
            if (LEXIT .gt. 1) then
               if (KDER .eq. 0) TP2 = 1.5D0 * abs(DX(0) / ADJSAV)
            end if
            ERREST = TP2 * (E2  + .0625D0 * E2L)
            if (LNDEG .ne. 0) IOPT(LNDEG) = L
            Y = YL
            go to 2000
  970       if (KGO .gt. 10) go to 400
c
 1000       if (KDER .lt. 0) go to 280
 1020       KK = min(N - IUI - ILI, 2) - 1
c In this section of code, KK=: 1, decrease ILI only; 0, increase IUI;
c -1, decrease ILI; and <-1, increase IUI only
            if (abs(KK) .eq. 1) then
               ILI = ILI - 1
               K = ILI
               if (ILI .ne. 0) then
                  if (INDXED) then
                     XL = XL + H
                     DX(L+1) = XL
                     go to 270
                  end if
                  DX(L+1) = XI - XT(K)
                  if (XT(ILI+1) .ne. XT(ILI)) go to 270
               end if
               if (KK .eq. 1) go to 1100
               N = 0
c                If all points will be on one side, flag extrapolation.
c               if (L .le. 0) go to 1250
            else
               IUI = IUI + 1
               K = IUI
               if (IUI .le. NTABI) then
                  if (INDXED) then
                     XU = XU - H
                     DX(L+1) = XU
                     go to 270
                  end if
                  DX(L+1) = XI - XT(K)
                  if (XT(IUI-1) .ne. XT(IUI)) go to 270
               end if
               if (KK .ne. 0) go to 1100
               N = 3*NTABI
c                If all points will be on one side, flag extarpolation.
c               if (L .le. 0) go to 1250
            end if
            if (KGO .lt. 4) go to 1020
c If we can't get the same number of points on either side, the
c continuous derivative case becomes standard interpolation.
            KGO = 1
            NDEGE = NDEGE - 1
            if (L .lt. NDEGE) go to 1020
            go to 360
c                                     No more data accessible.
 1100       if (L .le. 0) then
c                             Too many bad points, couldn't find points.
                Y = TP1
                IDAT(1) = L + 1
                IIFLG = -3
                go to 2110
            end if
            NDEGI = min(NDEGI, L)
            NDEGE = 0
            IIFLG = 2
            go to 360
c
c                                     Secant start, then use sequential
 1200    continue
            if (XT(1) .eq. XT(NTABI)) go to 1220
            ILI = max(1, min(NTABI, int(1.5D0+dble(NTABI-1)*(XI-XT(1))/
     1         (XT(NTABI) - XT(1)))))
         go to 210
c
c                         Special cases
c                                  1 entry in XT
 1220    ILI = 1
         IUI = 1
         KGO = 1
         K = 1
         if (NDEGE .ne. 0) IIFLG = 2
         NDEGE = 0
         if (NTABI .eq. 1) go to 250
c                         Error -- XT(1) .eq. XT(NTAB), and NTAB .ne. 1
         IIFLG = -4
         IDAT(1) = NTABI
         ERRDAT(1) = XT(1)
         KGO = 0
         go to 2120
c                  Check if really extrapolating
 1230    N = 6 * (ILI - 1)
         if ((XI - XT(1)) * (XT(NTABI) - XI) .ge. 0.D0) go to 240
c                                  Extrapolating
 1250    IIFLG = 1
         if (KGO .ge. 4) KGO = 1
         NDEGI = KEXTRP
         NDEGE = sign(NDEGI, NDEGE)
         if (INDXED) go to 260
         go to 240
c
c                                      Index search, then exit
 1300    continue
         INDXED = .true.
         H = XT(2)
         if (H .eq. 0) then
            IIFLG = -5
            go to 2120
         end if
         TP1 = 1.D0 + (XI - XT(1)) / H
         ILI = min(max(1, nint(TP1)), NTABI)
         XU = (TP1 - dble(ILI)) * H
         XL = XU
         DX(0) = XU
         N = ILI + ILI
         if (TP1 .gt. dble(ILI))  N = N + 1
         if ((XI - XT(1)) * ((XT(1) + H*dble(NTABI-1) - XI)) .ge. 0.E0)
     1     go to 260
         N = 6 * (ILI - 1)
         go to 1250
c
c                                 Already set up
 1400    KGO = KGOC
         if (KGO .eq. 0) then
            IIFLG = -7
            go to 2120
         end if
         YTORD = KGO .gt. 0
         KGO = abs(KGO)
         if (KGO .lt. 10) KGO = KGO + 10
         if (KGO .eq. 12) KGO = 11
         NDEGI = NDEGEC
         NDEGQ = NDEGI
         if (KGO .eq. 13) NDEGQ = 0
         NDEGE = -NDEGI
         L = -1
         if (KGO .eq. 14) NDEGI = NDEGI - 1
         go to 400
c
c                                 Set number of points for extrapolation
 1500    continue
            I = I + 1
            KEXTRP = min(IOPT(I), NDEGE)
            go to 10
c
c                                 Get derivatives of interpolant
 1600    continue
            I = I + 2
            LDERIV = IOPT(I-1)
            LEXIT = IOPT(I) + 1
            go to 10
c
c                                     Get expected errors in YT.
1900     continue
            I = I + 1
            LEXERR = IOPT(I)
c
c                                     Set to get error estimate.
 1930    continue
            GETERR = .true.
            go to 10
c
c                                     Set for automatic order selection.
 1950    continue
            IO = IO + 2
            LNDEG = IO
            EBND = max(0.D0, EOPT(IOPT(IO-1)))
            EBNDR = max(0.D0, EOPT(IOPT(IO-1)+1))
            KGO = 3
            KAOS = 1
            NDEGI = min(MAXDEG, NDEGE+1)
            NDEGE = -NDEGI
         go to 1930
c
c                                    Set to ignore special points
 1970    continue
            LBADPT = .true.
            IO = IO + 1
            BADPT = EOPT(IOPT(IO))
            go to 10
c
c                                    Set up for Hermite interpolation.
 1980    continue
         IO = IO + 1
         LDER = IOPT(IO)
         KDER = abs(LDER)
         go to 10
c
c                                    Put any new options just above here
c                    End of the loop
c
 2000 if (LEXIT .lt. 2) go to 2100
c                       Compute derivatives of Y
      SAVED = mod(KGO, 10) .eq. 4
      if (SAVED) then
         DXS = DX(L-1)
         DX(L-1) = DX(0)
      end if
      N = LEXIT - 1
      if (N .gt. L) then
        if (N .gt. MAXDEG) then
           IDAT(1) = N
           IDAT(2) = MAXDEG
           N = MAXDEG
           IIFLG = -6
        end if
        do 2020 I = L+1, N
           EOPT(I+LDERIV-1) = 0.D0
 2020   continue
        N = L
      end if
      TP1 = CY(1)
      PID(0) = 1.D0
      do 2030 I = 1, L-1
         PID(I) = PI(I) + DX(I) * PID(I-1)
         TP1 = TP1 + PID(I) * CY(I+1)
 2030 continue
      EOPT(LDERIV) = TP1
      do 2070 K = 2, N
         TP1 = CY(K)
         do 2060 I = 1, L-K
            PID(I) = PID(I) + DX(I+K-1) * PID(I-1)
            TP1 = TP1 + PID(I) * CY(I+K)
 2060    continue
         EOPT(K+LDERIV-1) = TP1
 2070 continue
      if (SAVED) DX(L-1) = DXS
c                                    Save info. and return
 2100 continue
      if (GETERR) then
         if (EPSR .eq. 0.D0) then
            EPSR = D1MACH(4)
         end if
         TP1 = EPSR
         TP2 = 0.D0
         if (LEXERR .ne. 0) then
            TP2 = max(0.D0, EOPT(LEXERR))
            TP1 = max(TP1, EOPT(LEXERR+1))
         end if
         if (IIFLG .eq. 2) ERREST = 32.D0 * ERREST
         EOPT(1) = ERREST + TP2 + TP1*(abs(CY(0)) + abs(DX(0)*CY(1)))
         if ((KGO .eq. 3) .or. (KGO .eq. 13)) then
            if (EBNDI .ne. 0.D0) then
               if (EOPT(1) .gt. EBND) then
                  ERRDAT(1) = EOPT(1)
                  ERRDAT(2) = EBND
                  IIFLG = -1
               end if
            end if
         end if
      end if
 2110 KGOC = -KGO
      NDEGEC = L
 2120 IOPT(1) = IIFLG
      if (IIFLG .ge. 0) return
c Take care of error messages, IIFLG < -2 should stop.
      MACT(2) = 88
      if (IIFLG .lt. -1) KAOS = -MACT(2)
      if (IIFLG .ge. -3) MACT(2) = min(26, 24 - IIFLG)
      if (IOPT(2) .ge. 254)  then
         if (IIFLG .eq. -1) return
         MACT(2) = 28
      end if
      MACT(3) = -IIFLG
      MACT(4) = MLOC(-IIFLG)
      call DMESS(MACT, MTXTAA, IDAT, ERRDAT)
      MACTV(2) = IO
      MACTV(5) = IO
      K = 1
      if (IO .eq. 1) K = 6
      call MESS(MACTV(K), MTXTAB, IOPT)
      return
c                       End of Interpolation routine -- DILUP
      end


program principal
    use types
    use box_pot_parameters
    use tensor, only: ih
    use utils
    use positions, only: position, position_ih
    use energies
    use observables
    use, intrinsic :: iso_fortran_env, only: output_unit

    implicit none

! Variables locales
    real(dp), allocatable :: rpos(:, :), f(:, :), r(:), g(:), h(:)
    real(dp), allocatable :: t(:), wt(:), ft(:)
! Deben ser `allocatable` dado que son arreglos grandes
    real(dp), allocatable :: cfx(:, :), cfy(:, :), cfz(:, :)

    real(dp) :: dr, d
    integer, parameter :: k = 3

    real(dp), allocatable :: dij(:, :)
    real(dp), allocatable :: Rz(:)

    integer :: i, istep, nprom, ncp, s
    real(dp) :: enerpot, epotn, virial, pressure
    logical :: pbc = .true.
    integer :: u, reps
    logical :: init_config, exists
    integer :: therm_steps, prod_steps

    ! Initialize the PRNG
    call random_seed()
    ! Read the input values from a file
    call parse_inputs("input.in", therm_steps, prod_steps, init_config, ncp)
    ! Compute the necessary parameters for the simulation
    rho = 6.0_dp * phi / pi
    boxl = (np/rho)**(1._dp/3._dp)
    rc = boxl/2.0_dp
    d = (1.0_dp/rho)**(1._dp/3._dp)
    dr = rc / mr

    write(output_unit, fmt='(a,1f12.8)') 'The length of the box is: ', boxl
    write(output_unit, fmt='(a,1f12.8)') 'The mean interparticle distance is: ', d
    write(output_unit, fmt='(a,1f12.8)') 'Cut radius: ', rc

    if (with_ih) then
        write(output_unit, fmt='(a)') 'With hydrodynamic interactions'
    else
        write(output_unit, fmt='(a)') 'Without hydrodynamic interactions'
    end if

! Inicializar la memoria de los arreglos
    allocate (rpos(k, np), f(k, np), source=0.0_dp)
    allocate (r(mr), g(mr), h(mr), source=0.0_dp)
    s = np*k
    allocate (dij(s, s), Rz(s), source=0.0_dp)

    ! Check if there is a previous configuration
    inquire(file='finalconBD.dat', exist=exists)
    ! If so, load it
    if (exists .and. init_config) then
        open(newunit=u, file='finalconBD.dat', status="old", action="read")
        write(unit=output_unit, fmt='(a)') 'Reading positions from file...'
        do i = 1, np
            read(u, *) rpos(:, i)
        end do
        close(u)
    ! If not, create a new configuration
    else
        call iniconfig(rpos, d)
    end if

    ! Compute initial forces and interactions
    call force(rpos, f, enerpot, virial)
    if (with_ih) call ih(rpos, np, dij, Rz)

!Energy of the initial configuration
    epotn = enerpot/real(np)
    write(output_unit, fmt='(a,f12.8)') 'E/N = ', epotn

! Comienza la termalización
!Periodic boundary conditions; pbc > 0
    open (newunit=u, file='energy_BD.dat', status='unknown')
    do istep = 1, therm_steps
        call position(rpos, f, pbc)
        call force(rpos, f, enerpot, virial)
        epotn = enerpot/real(np)
        pressure = rho + (virial / (3.0 * boxl**3))
        if (mod(istep, 100000) == 0) then
            write(output_unit, fmt='(i8,2f15.8)') istep, epotn, pressure
        end if
        if (mod(istep, therm_steps) == 0) then
            write(u, fmt='(3f16.8)') real(istep), epotn, pressure
        end if
    end do
    close (u)

    write(output_unit, fmt='(a)') 'The system has thermalized'

! Termina la termalización y se guarda la configuración final
    open (newunit=u, file='finalconBD.dat', status='unknown')
    do i = 1, np
        write(unit=u, fmt='(3f16.8)') rpos(:, i)
    end do
    close (u)

    mt = ncp / prod_steps
    nprom = 0
    pbc = .false.
    reps = 1 ! The frequency for updating the RPY tensor for HI

    allocate (cfx(mt, np), cfy(mt, np), cfz(mt, np), source=0.0_dp)
    allocate (t(mt), wt(mt), ft(mt), source=0.0_dp)

    ! Call the value for the HI
    if (with_ih) call ih(rpos, np, dij, Rz)

    ! Loop for production steps
    do i = 1, prod_steps
        if ( with_ih ) then
            call position_ih(rpos, f, dij, Rz, pbc)
        else
            call position(rpos, f, pbc)
        end if
        ! Compute the energy
        call force(rpos, f, enerpot, virial)
        epotn = enerpot/real(np)
        if ( (with_ih) .and. (mod(i,reps) == 0) ) call ih(rpos, np, dij, Rz)

        if (mod(i, 100000) == 0) then
            write(output_unit, fmt='(1i8,1f10.8)') i, epotn
        end if
        if (mod(i, prod_steps) == 0) then
            nprom = nprom + 1
            t(nprom) = deltat*prod_steps*(nprom - 1)
            cfx(nprom, :) = rpos(1, :)
            cfy(nprom, :) = rpos(2, :)
            cfz(nprom, :) = rpos(3, :)
            call gr(rpos, g, dr, .true.)
            ! Save positions to file
            call snapshots(rpos, i, 'production.xyz')
        end if
    end do

    call difusion(nprom, cfx, cfy, cfz, wt, ft)

    call save_msd(t, wt, ft, nprom, 'wt_fself.dat')
    call normalize(g,h,r,dr,nprom,'gr_ih.dat')
end program principal


!---------------------------------------------------------------------------------------------------
!
!	filename = quad.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 18/10/2013
!
!---------------------------------------------------------------------------------------------------

module quad
  use consts
  implicit none
contains

function integrateRTH( rho, r, th, Nr, Nth ) result( intgrt )
  integer, intent( in ) :: Nr, Nth
  double precision, intent( in ) :: r(Nr), th(Nth), rho(Nr,Nth)
  double precision :: intgrt
  integer :: i, j

  intgrt = 0.0D0
  !#omp parallel do shared(Nr,Nth,intgrt,rho,r,th) collapse(2)
  do i = 1,(Nr-1)
     do j = 1,(Nth-1)
        intgrt = intgrt + pi2_ * rho( i, j ) * ( ( r(i)**2.0D0 )* sin( th(j) ) ) * &
             ( r(i+1) - r(i) ) * ( th(j+1) - th(j) )
     end do
  end do

end function integrateRTH

end module quad


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

PROGRAM kinetic_test

    USE KINETIC
    USE OUTPUT, only: print_real_matrix
    USE CONSTANTS

    IMPLICIT NONE

    REAL*8, PARAMETER :: zeta_H = 1.24D0    ! STO coefficient correction for H
    REAL*8, PARAMETER :: zeta_He = 2.0925D0 ! STO coefficient correction for He
    REAL*8, PARAMETER :: zeta_O_1 = 7.66D0 ! STO coefficient correction for He
    REAL*8, PARAMETER :: zeta_O_2 = 2.25D0 ! STO coefficient correction for He

    ! ----------------
    ! BASIS SET FOR H2
    ! ----------------
    INTEGER, PARAMETER :: K_H2 = 2 ! Number of basis functions

    INTEGER, dimension(K_H2,3) :: basis_L_H2            ! Angular momenta of basis set Gaussians
    REAL*8, dimension(K_H2,3) :: basis_R_H2             ! Centers of basis set Gaussians
    REAL*8, dimension(K_H2,c) :: basis_D_H2, basis_A_H2 ! Basis set coefficients

    REAL*8, dimension(K_H2,K_H2) :: T_H2 ! Overlap matrix

    ! ------------------
    ! BASIS SET FOR HeH+
    ! ------------------
    INTEGER, PARAMETER :: K_HeH = 2 ! Number of basis functions

    INTEGER, dimension(K_HeH,3) :: basis_L_HeH              ! Angular momenta of basis set Gaussians
    REAL*8, dimension(K_HeH,3) :: basis_R_HeH               ! Centers of basis set Gaussians
    REAL*8, dimension(K_HeH,c) :: basis_D_HeH, basis_A_HeH  ! Basis set coefficients

    REAL*8, dimension(K_HeH,K_HeH) :: T_HeH ! Overlap matrix

    ! -----------------
    ! BASIS SET FOR H2O
    ! -----------------
    INTEGER, PARAMETER :: K_H2O = 7 ! Number of basis functions

    INTEGER, dimension(K_H2O,3) :: basis_L_H2O              ! Angular momenta of basis set Gaussians
    REAL*8, dimension(K_H2O,3) :: basis_R_H2O               ! Centers of basis set Gaussians
    REAL*8, dimension(K_H2O,c) :: basis_D_H2O, basis_A_H2O  ! Basis set coefficients

    REAL*8, dimension(K_H2O,K_H2O) :: T_H2O ! Overlap matrix

    ! -----------
    ! MOLECULE H2
    ! -----------

    basis_R_H2(1,1:3) = (/0.0D0, 0.0D0, 0.0D0/) ! Position of first H atom
    basis_R_H2(2,1:3) = (/1.4D0, 0.0D0, 0.0D0/) ! Position of the second H atom

    basis_L_H2(1,1:3) = (/0, 0, 0/) ! Angular momenta for the first basis function
    basis_L_H2(2,1:3) = (/0, 0, 0/) ! Angular momenta for the second basis function

    basis_D_H2(1,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_H2(2,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)

    basis_A_H2(1,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)
    basis_A_H2(2,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)

    CALL T_kinetic(K_H2,basis_D_H2,basis_A_H2,basis_L_H2,basis_R_H2,T_H2)

    WRITE(*,*) "Kinetic matrix T:"
    CALL print_real_matrix(K_H2,K_H2,T_H2)

    ! ------------
    ! MOLECULE He+
    ! ------------

    basis_R_HeH(1,1:3) = (/0.0D0, 0.0D0, 0.0D0/)    ! Position of the H atom
    basis_R_HeH(2,1:3) = (/1.4632D0, 0.0D0, 0.0D0/) ! Position of the He atom

    basis_L_HeH(1,1:3) = (/0, 0, 0/) ! Angular momenta for the first basis function
    basis_L_HeH(2,1:3) = (/0, 0, 0/) ! Angular momenta for the second basis function

    basis_D_HeH(1,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_HeH(2,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)

    basis_A_HeH(1,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)
    basis_A_HeH(2,1:c) = (/0.109818D0 * zeta_He**2, 0.405771 * zeta_He**2, 2.22766 * zeta_He**2/)

    CALL T_kinetic(K_HeH,basis_D_HeH,basis_A_HeH,basis_L_HeH,basis_R_HeH,T_HeH)

    WRITE(*,*) "Kinetic matrix T:"
    CALL print_real_matrix(K_HeH,K_HeH,T_HeH)

    ! ------------
    ! MOLECULE H2O
    ! ------------

    basis_R_H2O(1,1:3) = (/0.0D0, 1.43233673D0, -0.96104039D0/)     ! Center of H1 1s
    basis_R_H2O(2,1:3) = (/0.0D0, -1.43233673D0, -0.96104039D0/)    ! Center of H2 1s
    basis_R_H2O(3,1:3) = (/0.0D0, 0.0D0, 0.24026010D0/)             ! Center of O 1s
    basis_R_H2O(4,1:3) = (/0.0D0, 0.0D0, 0.24026010D0/)             ! Center of O 2s
    basis_R_H2O(5,1:3) = (/0.0D0, 0.0D0, 0.24026010D0/)             ! Center of O 2px
    basis_R_H2O(6,1:3) = (/0.0D0, 0.0D0, 0.24026010D0/)             ! Center of O 2py
    basis_R_H2O(7,1:3) = (/0.0D0, 0.0D0, 0.24026010D0/)             ! Center of O 2pz

    basis_L_H2O(1,1:3) = (/0, 0, 0/) ! Angular momenta for H 1s
    basis_L_H2O(2,1:3) = (/0, 0, 0/) ! Angular momenta for H 1s
    basis_L_H2O(3,1:3) = (/0, 0, 0/) ! Angular momenta for O 1s
    basis_L_H2O(4,1:3) = (/0, 0, 0/) ! Angular momenta for O 2s
    basis_L_H2O(5,1:3) = (/1, 0, 0/) ! Angular momenta for O 2px
    basis_L_H2O(6,1:3) = (/0, 1, 0/) ! Angular momenta for O 2py
    basis_L_H2O(7,1:3) = (/0, 0, 1/) ! Angular momenta for O 2pz

    basis_D_H2O(1,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_H2O(2,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_H2O(3,1:c) = (/0.444635D0, 0.535328D0, 0.154329D0 /)
    basis_D_H2O(4,1:c) = (/0.700115D0, 0.399513D0, -0.0999672D0/)
    basis_D_H2O(5,1:c) = (/0.391957D0, 0.607684D0, 0.1559163D0/)
    basis_D_H2O(6,1:c) = (/0.391957D0, 0.607684D0, 0.1559163D0/)
    basis_D_H2O(7,1:c) = (/0.391957D0, 0.607684D0, 0.1559163D0/)

    basis_A_H2O(1,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)
    basis_A_H2O(2,1:c) = (/0.109818D0 * zeta_H**2, 0.405771 * zeta_H**2, 2.22766 * zeta_H**2/)
    basis_A_H2O(3,1:c) = (/0.109818D0 * zeta_O_1**2, 0.405771 * zeta_O_1**2, 2.22766 * zeta_O_1**2/)
    basis_A_H2O(4,1:c) = (/0.0751386D0 * zeta_O_2**2, 0.231031 * zeta_O_2**2, 0.994203 * zeta_O_2**2/)
    basis_A_H2O(5,1:c) = (/0.0751386D0 * zeta_O_2**2, 0.231031 * zeta_O_2**2, 0.994203 * zeta_O_2**2/)
    basis_A_H2O(6,1:c) = (/0.0751386D0 * zeta_O_2**2, 0.231031 * zeta_O_2**2, 0.994203 * zeta_O_2**2/)
    basis_A_H2O(7,1:c) = (/0.0751386D0 * zeta_O_2**2, 0.231031 * zeta_O_2**2, 0.994203 * zeta_O_2**2/)

    CALL T_kinetic(K_H2O,basis_D_H2O,basis_A_H2O,basis_L_H2O,basis_R_H2O,T_H2O)

    WRITE(*,*) "Kinetic matrix T:"
    CALL print_real_matrix(K_H2O,K_H2O,T_H2O)

END PROGRAM kinetic_test


 program test
       integer :: i,j
       complex :: M,N
       complex,pointer :: A(:)

       allocate(A(10))
       M=(0,0)

       do i=1, 10
         A(i)=(1,1)
       enddo

 !$omp target teams distribute map(to:A) map(tofrom:M) reduction(+:M)
       do i=1, 10
         N=(0,0)
 !$omp parallel do reduction(+:N)
         do j=1, 10
           N=N+A(j)
         enddo
 !$omp end parallel do
         M=M+N
       enddo
 !$omp end target teams distribute

       write(*, *), "M=", M

 end program test


! ::
! :: ----------------------------------------------------------
! :: INPUTS / OUTPUTS:
! ::  dat        => field to be summed
! ::  rlo,rhi    => index limits of dat array
! ::  lo,hi      => index limits of tilebox
! ::  dx         => cell size
! ::  s         <=  volume-weighted sum
! :: ----------------------------------------------------------
! ::

      subroutine sum_over_level(dat,r_l1,r_l2,r_l3,r_h1,r_h2,r_h3,lo,hi,dx,s) &
        bind(C, name="sum_over_level")

        use amrex_fort_module, only : rt => amrex_real
        implicit none
        integer          :: r_l1,r_l2,r_l3,r_h1,r_h2,r_h3
        integer          :: lo(3), hi(3)
        real(rt) :: s, dx(3)
        real(rt) :: dat(r_l1:r_h1,r_l2:r_h2,r_l3:r_h3)

        integer          :: i, j, k

        s    = 0.d0

        do k = lo(3), hi(3)
           do j = lo(2), hi(2)
              do i = lo(1), hi(1)
                 s = s + dat(i,j,k)
              enddo
           enddo
        enddo

        s = s * (dx(1)*dx(2)*dx(3))

      end subroutine sum_over_level

! ::
! :: ----------------------------------------------------------
! :: INPUTS / OUTPUTS:
! ::  dat1       =>  first field
! ::  dat2       => second field
! ::  rlo,rhi    => index limits of dat1 array
! ::  slo,shi    => index limits of dat2 array
! ::  lo,hi      => index limits of tilebox
! ::  dx         => cell size
! ::  s         <=  volume-weighted sum
! :: ----------------------------------------------------------
! ::

      subroutine sum_product(dat1,r_l1,r_l2,r_l3,r_h1,r_h2,r_h3,&
                             dat2,s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,lo,hi,dx,s) &
        bind(C, name="sum_product")

        use amrex_fort_module, only : rt => amrex_real
        implicit none
        integer          :: r_l1,r_l2,r_l3,r_h1,r_h2,r_h3
        integer          :: s_l1,s_l2,s_l3,s_h1,s_h2,s_h3
        integer          :: lo(3), hi(3)
        real(rt) :: s, dx(3)
        real(rt) :: dat1(r_l1:r_h1,r_l2:r_h2,r_l3:r_h3)
        real(rt) :: dat2(s_l1:s_h1,s_l2:s_h2,s_l3:s_h3)

        integer          :: i, j, k

        s    = 0.d0

        do k = lo(3), hi(3)
           do j = lo(2), hi(2)
              do i = lo(1), hi(1)
                 s = s + dat1(i,j,k)*dat2(i,j,k)
              enddo
           enddo
        enddo

        s = s * (dx(1)*dx(2)*dx(3))

      end subroutine sum_product

! ::
! :: ----------------------------------------------------------
! :: INPUTS / OUTPUTS:
! ::  dat1       =>  first field
! ::  dat2       => second field
! ::  dat3       =>  third field
! ::  rlo,rhi    => index limits of rho array
! ::  lo,hi      => index limits of tilebox
! ::  dx         => cell size
! ::  s         <=  volume-weighted sum
! :: ----------------------------------------------------------
! ::

      subroutine sum_prod_prod(dat1,r_l1,r_l2,r_l3,r_h1,r_h2,r_h3,&
                               dat2,s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,&
                               dat3,t_l1,t_l2,t_l3,t_h1,t_h2,t_h3,lo,hi,dx,s) &
        bind(C, name="sum_prod_prod")

        use amrex_fort_module, only : rt => amrex_real
        implicit none

        integer          :: r_l1,r_l2,r_l3,r_h1,r_h2,r_h3
        integer          :: s_l1,s_l2,s_l3,s_h1,s_h2,s_h3
        integer          :: t_l1,t_l2,t_l3,t_h1,t_h2,t_h3
        integer          :: lo(3), hi(3)
        real(rt) :: s, dx(3)
        real(rt) :: dat1(r_l1:r_h1,r_l2:r_h2,r_l3:r_h3)
        real(rt) :: dat2(s_l1:s_h1,s_l2:s_h2,s_l3:s_h3)
        real(rt) :: dat3(t_l1:t_h1,t_l2:t_h2,t_l3:t_h3)

        integer          :: i, j, k

        s    = 0.d0

        do k = lo(3), hi(3)
           do j = lo(2), hi(2)
              do i = lo(1), hi(1)
                 s = s + dat1(i,j,k)*dat2(i,j,k)*dat3(i,j,k)
              enddo
           enddo
        enddo

        s = s * (dx(1)*dx(2)*dx(3))

      end subroutine sum_prod_prod


*************************************************************************
C      PROGRAM: SDE
C       ----------------
C       SIMULATES SDE
*************************************************************************
C
C       Reference: Unpublished/ Peter D. Drummond, 16 Nov 1994
C       Algorithm:  Stochastic phase space
C
***************************************************************************
C
C       ps      program switches:
C                ps(1) = algorithm switch, to alter the sde
C                ps(2) = sde type; =1,2 (for dimension-doubling)
C                ps(3) = integration option ; not currently used
C                ps(4) = modes/lattice point
C                ps(5) = variables/lattice point (ie. =ps(2)*ps(4))
C                ps(6) = unused
C                ps(7) = real noises per point   - depends on the sde
C                ps(8) = iterations of the implicit sde solver
C
C  PARAMETER VALUES
C
        integer MSEED,MPATH,MPT,MSTEP
        integer MM,MV,MN,MPA,MPRINTS
        parameter (MSEED = 100000000)
        parameter (MPATH = 1000000)
        parameter (MPT = 1024)
        parameter (MSTEP = 1024)
        parameter (MM = 10)
        parameter (MV = 10)
        parameter (MN = 10)
        parameter (MPA = 10)
        parameter (MPRINTS = 10)
C
C  DATA DECLARATIONS
C
C       include 'param.f'
        complex*16 z_i(MV),z_c(MV),z_f(MV)
        complex*16 ps_c, ps_f,ci,ci2
        complex*16  A(MV),pa(MPA),lpa(MPA)
        real*8 delw_1(MN), delw_2(MN), delw_t(MN)
        real*8 time,deltc,deltf,sigma,pi,pi2
        real*8 gauss,x,i(2*MV),s(MN)
        real*8 nc,n2c,nf,n2f,error,time1,nsigma
        real*8 errormax,errpoint,timec,timef
        real*8 sigmamax,sigpoint
        real*8 out_c(2,0:MM,0:MPT),out_f(2,0:MM,0:MPT)
        integer seed,paths,points,steps,moms,n
        integer path,point,step,mom,fn
        integer var,noise,ps(10),j(10)
        integer n_print
C
C  CONSTANTS
C
        ci=(0.,1.d0)
        pi=4.*atan(1.d0)
        pi2=2.*pi
        fn=9
C
C  INPUT SIMULATION DATA TO START
C
        open(fn, file='SDE1.dat',status='unknown',form='formatted')
        write(*,*) ' _________________________________________________ '
        write(*,*) '|                                                 |'
        write(*,*) '| SDE VERSION 1.0                                 |'
        write(*,*) '|                                                 |'
        write(*,*) '| SIMULATES SDE - COPYRIGHT PETER D DRUMMOND 1996 |'
                                  |'
        write(*,*) '|                                                 |'
        write(*,*) '| Estimates of sampling error, step error made.   |'
        write(*,*) '|                                                 |'
        write(*,*) '| Output is re-usable as an input OR gnuplot file.|'
                                  |'
        write(*,*) '|                                                 |'
        write(*,*) '|_________________________________________________|'
        write(fn,*) '# PROGRAM: SDE VERSION 1.0'
        call input(1,'seed                ',1.d0,MSEED*1.d0,x,seed,fn)
        call input(1,'paths               ',1.d0,MPATH*1.d0,x,paths,fn)
        call input(1,'points              ',1.d0,MPT*1.d0,x,points,fn)
        call input(1,'steps/pnt           ',1.d0,MSTEP*1.d0,x,steps,fn)
        call input(1,'iterations          ',1.d0,MSTEP*1.d0,x,ps(8),fn)
        call input(1,'max moment          ',1.d0,MM*1.d0,x,moms,fn)
        call input(1,'max time            ',0.0d0,1.D100,time,n,fn)
        deltc = time/(steps*points)
        deltf=deltc/2.
        sigma=1./sqrt(deltf)                            !sd = sqrt(1/ timestep)
        n_print=max0(1,paths/MPRINTS)
C        n_fractf=0
C        n_fractc=0
C
D       write(*,*) 'deltc,deltf,sigma = ', deltc,deltf,sigma
C  INITIALISE RANDOM NUMBERS
C
        call in_rand (seed)                             !initialize random
numbers
C
C  INITIALISE EQUATION PARAMETERS
C
        call equ_par (ps,pa,fn)
        call equ_in (ps,lpa,z_i,fn)
        write(*,*) ' _________________________________________________'
        write(*,*) '|                                                 |'
        write(*,*) '| INPUT std deviation, sigma=sigma_x=sigma_y      |'
        write(*,*) '| IE assumed equal real and imaginary fluctuations|'
        write(*,*) '|_________________________________________________|'
        call input(ps(4),'input std deviation ',0.0d0,1.D100,i,j,fn)
        call input(ps(7),'stochastic sd: [b_n]',0.0d0,1.D100,s,j,fn)
        do var=1,ps(7)
                s(var)=sigma*s(var)
        end do
D       write(*,*) 'deltc,deltf,sigma = ', deltc,deltf,sigma
C
C  LOOP AROUND ENSEMBLE
C
         do  path=1,paths
                if ((path/n_print)*n_print.eq.path) then
                        write(*,*) 'Starting path ',path,' / ',paths
                end if
                call gauss(ps(4),i,delw_1,delw_2,delw_t)
                ps_c=(0.,0.)
                ps_f=(0.,0.)
                do var=1,ps(4)
                        z_c(var) = z_i(var)+delw_1(var)+ci*delw_2(var)
                        z_f(var) = z_c(var)
                end do
                if (ps(2).eq.2) then
                do var=1,ps(4)
                        z_c(ps(4)+var) = z_c(var)
                        z_f(ps(4)+var) = z_c(var)
                end do
                end if
                call calc(ps,ps_c,z_c,out_c,moms,0)
                call calc(ps,ps_f,z_f,out_f,moms,0)
                do point=1,points
                  do step=1,steps
                     call gauss(ps(7),s,delw_1,delw_2,delw_t)
C
C  COARSE AND FINE INTEGRATION STEPS
C
D               write(*,*) 'ps_c,z_c,delw_t,deltc'
D               write(*,*) ps_c,z_c,delw_t,deltc
D               write(*,*) 'pa,ps(5)'
D               write(*,*) pa,ps(5)
D               write(*,*) 'COARSE:STEP=' ,step
                call intg(ps,ps_c,z_c,delw_t,deltc,pa,lpa)
D               write(*,*) 'FINE:STEP=' ,step
                call intg(ps,ps_f,z_f,delw_1,deltf,pa,lpa)
                     call intg(ps,ps_f,z_f,delw_2,deltf,pa,lpa)
                  end do
                  call calc(ps,ps_c,z_c,out_c,moms,point)
                  call calc(ps,ps_f,z_f,out_f,moms,point)
                end do
C
C     END PATH
C
        end do
C
C     END ENSEMBLE
C
        sigmamax=0.
        errormax=0.
        errpoint=0
        sigpoint=0
        do  mom=1,moms
             write(*,*) 'MOMENT = ' , mom
             write(*,*) 'Time     n     error(tot)     error(step)'
             write(*,*) '*******************************************'
             do  point=0,points
                nc =out_c(1,mom,point)/paths
                n2c=out_c(2,mom,point)/paths
                nf =out_f(1,mom,point)/paths
                n2f=out_f(2,mom,point)/paths
                error=abs(nc-nf)
                nsigma=0.
                if (paths.gt.1)  then
                        nsigma = sqrt(abs(n2f-nf**2)/(paths -1))
                end if
                if (nsigma.gt.sigmamax) then
                        sigmamax=nsigma
                        sigpoint=point
                endif
                nsigma = error+nsigma
                if (error.gt.errormax) then
                        errormax=error
                        errpoint=point
                endif
                time1=point*deltc*steps
                write(*,700) time1, nf, nsigma, error
                write(fn,700) time1, nf, nsigma, error
             end do
        write(fn,*)
        end do
700             format (4G14.6)
             write(*,*) '*******************************************'
C             timec =  n_fractc*time/(paths*steps*points)
C             timef =  n_fractf*time/(2*paths*steps*points)
             write(*,*) '*SUCCESSFUL FINISH'
             write(*,*) '*COMPLETED              ', paths, ' PATHS'
             write(*,*) '*TOTAL TIME          =  ', time
C             write(*,*) '*TIME ON SURFACE(C)  =  ', timec
C            write(*,*) '*TIME ON SURFACE(F)  =  ', timef
             write(*,*) '*WORST STEP ERROR    =  ', errormax
             write(*,*) '*OCCURRED AT TIME    =  ',errpoint*deltc*steps
             write(*,*) '*WORST STD ERROR    =   ', sigmamax
             write(*,*) '*OCCURRED AT TIME    =  ',sigpoint*deltc*steps
             write(*,*) '*******************************************'
C             write(fn,*) '#TIME ON SURFACE(C)  =  ', timec
C             write(fn,*) '#TIME ON SURFACE(F)  =  ', timef
             write(fn,*) '#WORST STEP ERROR    =  ', errormax
             write(fn,*) '#OCCURRED AT TIME    =  ',errpoint*deltc*steps
             write(fn,*) '#WORST STD ERROR    =   ', sigmamax
             write(fn,*) '#OCCURRED AT TIME    =  ',sigpoint*deltc*steps
             stop
             end
C
C     END PROGRAM
C
*************************************************************************
C       SUBROUTINE: EQU_IN
C       ----------------
C       RETURNS EQUATION PARAMETERS
*************************************************************************
        subroutine  equ_in (ps,lpa,z_i,fn)
C
C       Reference: None
C       Algorithm:  Simple data input routine
C
        complex*16 x,z_i(*),lpa(*)
        integer var,fn,n,ps(10)
        do var=1,ps(5)
        write(*,*) ' _________________________________________________ '
        write(*,*) '|                                                 |'
        write(*,*) '| Variable,',var,'                           |'
        write(*,*) '|                                                 |'
        write(*,*) '|_________________________________________________|'
        call input(2,'complex gain        ',-1.d9,1.d9,lpa(var),n,fn)
        call input(2,'initial amplitude   ',0.d0,1.d9,x,n,fn)
        z_i(var)=x
        end do
        return
        end
*************************************************************************
C       SUBROUTINE: INTG
C       ----------------
C       INTEGRATES ONE TIME STEP
*************************************************************************
        subroutine intg(ps,psi,z,delw,delt,pa,lpa)
C
C       Reference:   Drummond & Mortimer
C       Algorithm:   Iterated central partial difference
C
C
C  PARAMETER VALUES
C
               integer MSEED,MPATH,MPT,MSTEP
               integer MM,MV,MN,MPA
               parameter (MSEED = 100000000)
               parameter (MPATH = 1000000)
               parameter (MPT = 1024)
               parameter (MSTEP = 1024)
               parameter (MM = 10)
               parameter (MV = 10)
               parameter (MN = 10)
               parameter (MPA = 10)
C
C  DATA DECLARATIONS
C
        complex*16 z(MV),z_m(MV),del_z(MV),pa(*),lpa(*),psi
        real*8 delw(MN)
        real*8 delt
        integer ps(10),iter,var
        do var=1,ps(5)
                z_m(var)=z(var)
        end do
        do iter=1,ps(8)
                   call deriv(ps,z_m,delw,del_z,pa)!get deriv
                        do var=1,ps(5)
                                del_z(var)=del_z(var)+lpa(var)*z_m(var)
                                z_m(var)=z(var)+del_z(var)*delt/2.d0
                        end do
        end do
        do var=1,ps(5)
                z(var)=z(var)+del_z(var)*delt
        end do
        return
        end
*************************************************************************
C       SUBROUTINE: CALC
C       ----------------
C       CALCULATES MOMENTS
*************************************************************************
        subroutine  calc(ps,psi,z,out,moms,point)
C
C       Reference: none
C       Algorithm: calculates  moments
C
C
C  PARAMETER VALUES
C
               integer MSEED,MPATH,MPT,MSTEP
               integer MM,MV,MN,MPA
               parameter (MSEED = 100000000)
               parameter (MPATH = 1000000)
               parameter (MPT = 1024)
               parameter (MSTEP = 1024)
               parameter (MM = 10)
               parameter (MV = 10)
               parameter (MN = 10)
               parameter (MPA = 10)
        complex*16 z(MV),psi,zc
        real*8 n1
        real*8 out(2,0:MM,0:MPT)
        integer mom,moms,point,ps(*),var,exp
        do  mom = 1,moms
                exp=1+(mom-1)/ps(4)
                var=mom-(exp-1)*ps(4)
              zc =z(var)
              if (ps(2).eq.2) zc=z(var+ps(4))
              zc=dconjg(zc)
              n1=       ((z(var))*zc )**exp             !compute variable
              out(1,mom,point) = out(1,mom,point)+n1    !store variable
              out(2,mom,point) = out(2,mom,point)+n1**2 !store variance
        end do
        return
        end
*************************************************************************
C       SUBROUTINE: INPUT
C       ----------------
C       RETURNS INPUT PARAMETERS
C       COPYRIGHT:  ALL RIGHTS RESERVED - Peter D. Drummond, 27/04/96
*************************************************************************
        subroutine  input(nmax,name,min,max,r_v,i_v,f)
C
C       Reference: None
C       Algorithm:  Simple data input routine
C
C       WARNING -  KEEP    ML > = MAXD+1  TO AVOID OUT OF BOUNDS
C
        integer len_trim        !FUNCTION TO RETURN TRIMMED STRING LENGTH
        integer n,nmax,ML
        parameter (ML = 10)
        real*8 min,max,r_v(nmax)
        real*4 r4(ML)
        character*20 name
        character*180 data
        integer i_v(nmax),f,iflag,inerr
        iflag = -1
        inerr = 0
        if (nmax.le.0) return
        if (nmax.gt.ML) then
                write(*,*) nmax,' values wanted, only ' ,ML, ' allowed.'
                stop
        end if
        do while (iflag.lt.0.and.inerr.ge.0)
        write(*,*)
     1  ' ____________________________________________________________'
        write(*,*) '| Please input',nmax,' number(s) for ', name,'|'
        write(*,*) '| In range: ',min,'-',max           , '|'
        write(*,*)
     1  '|____________________________________________________________|'
            read(*,'(a180)',iostat=inerr) data
            iflag=1
            n=1
            if (data(1:1).eq.' ') n=2
            if (data(n:n).eq.'#') then
                if (data(n+1:n+1).eq.'t') then
                        write(f,'(a60)',iostat=inerr) data
                        iflag=-1
                end if
                data(n:n) = ' '
            end if
            if (inerr.ge.0.and.iflag.eq.1) then
                read(data,*,iostat=iflag) (r_v(n),n=1,nmax)
                if (iflag.ge.0) then
                  do n=1,nmax
                        if (r_v(n).lt.min) then
                        write(*,*) 'Input too small, you must try again'
                            iflag = -1
                        end if
                        if (r_v(n).gt.max) then
                        write(*,*) 'Input too big, you must try again'
                            iflag = -1
                        end if
                  end do
                end if
            end if
        end do
        do n=1,nmax
                i_v(n)=int(r_v(n))
                r4(n)=r_v(n)
        end do
        write(*,*) 'OK: ',(r4(n),n=1,nmax)
        write(data,*) (r4(n),n=1,nmax)
        write(f,'(1x, 4a)') '#',data(:len_trim(data)),'       ',name
        return
        end
*************************************************************************
C       FUNCTION: LEN_TRIM
C       ------------------
C       RETURN THE LENGTH OF A STRING LESS TRAILING SPACES
*************************************************************************
        integer function len_trim(str)
C
        character*(*) str
        integer l
        if (str .eq. ' ') then
           l = 1
        else
           l = len(str)
           do while (str(l:l) .eq. ' ')
              l = l-1
           end do
        end if
        len_trim = l
        return
        end
*************************************************************************
C       FUNCTION: GAUSS
C       ----------------
C       GAUSSIAN RANDOM NUMBER GENERATOR
C       COPYRIGHT:  ALL RIGHTS RESERVED - Peter D. Drummond, 27/04/96
*************************************************************************
        subroutine gauss(nl,s,b1,b2,bc)
C
C       Reference: Numerical Recipes
C       Algorithm: Box Mueller
C       Function:
C               - returns nl real gaussian random numbers in b1,b2,bc
C               - variance = <b^2> = s(n)^2, mean = 0, in  b1(n),b2(n)
C               - b1,b2 arrays are for the fine lattice calculation!
C               - bc is the average for the coarse lattice calculation!
        integer nl,n
        real*8 s(nl)
        real*8 randmzt,pi2,r1,r2
        real*8 bc(nl)
C               real*8 test1,test2,test12       !DEBUG
        real*8 b1(nl),b2(nl)
        complex*16 c
        pi2=8.*atan(1.d0)
        do  n=1,nl                      !lattice
                r1=randMZT()
                r2=randMZT()
                c=dsqrt(-2.d0*dlog(r1))*cdexp((0.d0,1.d0)*pi2*r2)*s(n)
                b1(n)=dreal(c)
                b2(n)=dimag(c)
                bc(n)=0.5D0*(dreal(c)+dimag(c))
        end do
C       write(*,*) 'Gauss',b1(1,1),b2(1,1),bc(1,1)
C       test1=0.d0
C       test2=0.d0
C       test12=0.d0
C       do n=1,nl
C       test1=test1+b1(n)**2
C       test2=test2+b2(n)**2
C       test12=test12+b1(n)*b2(n)
C       end do
C       write(*,*) ' variance =  ', test1/(nl),test2/(nl),test12/(nl)
C       write(*,*) ' expected =  ', s(1)**2,s(1)**2,'  0.0'
        return
        end
*************************************************************************
C       SUBROUTINE: INPUT
C       ----------------
C       RETURNS INPUT PARAMETERS
*************************************************************************
        subroutine  oinput (name,min,max,r_var,i_var,fn)
C
C       Reference: None
C       Algorithm:  Simple data input routine
C
        real*8 min,max,r_var
        character*12 name, data
        integer i_var,fn,iflag,inerr
        iflag = -1
        inerr = 0
        do while (iflag.lt.0.and.inerr.ge.0)
            write(*,*) 'Input: ',name,' Range:',min,'-',max
c                   write(*,*) '1'
            read(*,'(a12)',iostat=inerr) data
c                   write(*,*) '2',data
            if (data(1:1).eq.'#') data(1:1) = ' '
            if (data(2:2).eq.'#') data(2:2) = ' '
            if (inerr.ge.0) then
                read(data,*,iostat=iflag) r_var
c                       write(*,*) '3',data,r_var
c                       write(*,*) 'input',r_var,min,max
                if (iflag.ge.0) then
                        if (r_var.lt.min) then
                            write(*,*) 'Input too small'
                            iflag = -1
                        end if
                        if (r_var.gt.max) then
                            write(*,*) 'Input too large'
                            iflag = -1
                        end if
                end if
            end if
        end do
        i_var=int(r_var)
        write(*,*) name ,' = ', r_var
        write(fn,*) '# ',  r_var,'       ',name
        return
        end
*************************************************************************
C       FUNCTION: GAUSS
C       ----------------
C       GAUSSIAN RANDOM NUMBER GENERATOR
*************************************************************************
        subroutine ogauss(delw1,delw2,sigma,pi2,noises)
C
C       Reference: Numerical Recipes
C       Algorithm: Box Mueller
C
        real*8 sigma,randmzt,pi2,r1,r2,delw1(*),delw2(*)
        complex*16 c
        integer noise,noises
        do 100 noise=1,noises
        r1=randMZT()
        r2=randMZT()
        c = dsqrt(-2.d0*dlog(r1))*cdexp((0.,1.)*pi2*r2)*sigma
        delw1(noise)=dreal(c)
100     delw2(noise)=dimag(c)
        return
        end
*************************************************************************
C       FUNCTION: RANDOM
C       ----------------
C       PORTABLE PSEUDORANDOM NUMBER GENERATOR
*************************************************************************
        real*8 function randMZT ()
C
C       Reference: F.James, Comput. Phys. Commun. 60 (1990) 329.
C       Algorithm: G.Marsaglia, A.Zaman and W.-W. Tsang,
C               Stat. Prob. Lett. 9 (1990) 35.


*DECK CACOS
      COMPLEX FUNCTION CACOS (Z)
C***BEGIN PROLOGUE  CACOS
C***PURPOSE  Compute the complex arc cosine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      COMPLEX (CACOS-C)
C***KEYWORDS  ARC COSINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CACOS(Z) calculates the complex trigonometric arc cosine of Z.
C The result is in units of radians, and the real part is in the
C first or second quadrant.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CASIN
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CACOS
      COMPLEX Z, CASIN
      SAVE PI2
      DATA PI2 /1.5707963267 9489661923E0/
C***FIRST EXECUTABLE STATEMENT  CACOS
      CACOS = PI2 - CASIN (Z)
C
      RETURN
      END


      subroutine fpbspl(t,n,k,x,l,h)
c  subroutine fpbspl evaluates the (k+1) non-zero b-splines of
c  degree k at t(l) <= x < t(l+1) using the stable recurrence
c  relation of de boor and cox.
c  Travis Oliphant  2007
c    changed so that weighting of 0 is used when knots with
c      multiplicity are present.
c    Also, notice that l+k <= n and 1 <= l+1-k
c      or else the routine will be accessing memory outside t
c      Thus it is imperative that that k <= l <= n-k but this
c      is not checked.
c  ..
c  ..scalar arguments..
      real*8 x
      integer n,k,l
c  ..array arguments..
      real*8 t(n),h(20)
c  ..local scalars..
      real*8 f,one
      integer i,j,li,lj
c  ..local arrays..
      real*8 hh(19)
c  ..
      one = 0.1d+01
      h(1) = one
      do 20 j=1,k
        do 10 i=1,j
          hh(i) = h(i)
  10    continue
        h(1) = 0.0d0
        do 20 i=1,j
          li = l+i
          lj = li-j
          if (t(li).ne.t(lj)) goto 15
          h(i+1) = 0.0d0
          goto 20
  15      f = hh(i)/(t(li)-t(lj))
          h(i) = h(i)+f*(t(li)-x)
          h(i+1) = f*(x-t(lj))
  20  continue
      return
      end


program test_gaunt

! Compare the output from this test with the gaunt_log file, which was manually
! checked against the table 1^6, page 178, 179 in Condon & Shortley, The Theory
! of Atomic Spectra --- all numbers there are correct.

use types, only: dp
use special_functions, only: getgaunt
use utils, only: assert
use hfprint, only: lmap
implicit none

integer :: Lmax
real(dp), allocatable :: ck(:, :, :, :, :)
integer :: l, lp, m, mp, k

Lmax = 3
call getgaunt(Lmax, ck)
print *, "l + l' odd"
do l = 0, Lmax
    do lp = l, Lmax
        if (mod(l + lp, 2) == 0) cycle
        print "(a, 3i9)", "Dk:       ", Dk(1, l, lp), Dk(3, l, lp), Dk(5, l, lp)
        do m = l, 0, -1
            do mp = lp, 0, -1
                print "(2a2,2i3,3i9)", lmap(l), lmap(lp), m, mp, &
                    f(1, ck(1, l, m, lp, mp)), &
                    f(3, ck(3, l, m, lp, mp)), &
                    f(5, ck(5, l, m, lp, mp))
                do k = 0, 2*Lmax
                    call assert(ck(k, l, m, lp, mp)-ck(k, l, -m, lp, -mp) &
                        < 1e-10_dp)
                end do
            end do
        end do
        do m = l, 1, -1
            do mp = lp, 1, -1
                print "(2a2,2i3,3i9)", lmap(l), lmap(lp), m, -mp, &
                    f(1, ck(1, l, m, lp, -mp)), &
                    f(3, ck(3, l, m, lp, -mp)), &
                    f(5, ck(5, l, m, lp, -mp))
                do k = 0, 2*Lmax
                    call assert(ck(k, l, m, lp, -mp)-ck(k, l, -m, lp, mp) &
                        < 1e-10_dp)
                end do
            end do
        end do
    end do
end do
print *
print *, "l + l' even"
do l = 0, Lmax
    do lp = l, Lmax
        if (mod(l + lp, 2) == 1) cycle
        print "(a, 4i10)", "Dk:       ", Dk(0, l, lp), Dk(2, l, lp), &
            Dk(4, l, lp), Dk(6, l, lp)
        do m = l, 0, -1
            do mp = lp, 0, -1
                print "(2a2,2i3,4i10)", lmap(l), lmap(lp), m, mp, &
                    f(0, ck(0, l, m, lp, mp)), &
                    f(2, ck(2, l, m, lp, mp)), &
                    f(4, ck(4, l, m, lp, mp)), &
                    f(6, ck(6, l, m, lp, mp))
                do k = 0, 2*Lmax
                    call assert(ck(k, l, m, lp, mp)-ck(k, l, -m, lp, -mp) &
                        < 1e-10_dp)
                end do
            end do
        end do
        do m = l, 1, -1
            do mp = lp, 1, -1
                print "(2a2,2i3,4i10)", lmap(l), lmap(lp), m, -mp, &
                    f(0, ck(0, l, m, lp, -mp)), &
                    f(2, ck(2, l, m, lp, -mp)), &
                    f(4, ck(4, l, m, lp, -mp)), &
                    f(6, ck(6, l, m, lp, -mp))
                do k = 0, 2*Lmax
                    call assert(ck(k, l, m, lp, -mp)-ck(k, l, -m, lp, mp) &
                        < 1e-10_dp)
                end do
            end do
        end do
    end do
end do

contains

integer function Dk(k, l, lp)
integer, intent(in) :: k, l, lp
Dk = 0
if (l == 0 .and. lp == 0) then
    if (k == 0) Dk = 1
else if (l == 0 .and. lp == 1) then
    if (k == 1) Dk = 3
else if (l == 0 .and. lp == 2) then
    if (k == 2) Dk = 5
else if (l == 0 .and. lp == 3) then
    if (k == 3) Dk = 7
else if (l == 1 .and. lp == 1) then
    if (k == 0) then
        Dk = 1
    else if (k == 2) then
        Dk = 25
    end if
else if (l == 1 .and. lp == 2) then
    if (k == 1) then
        Dk = 15
    else if (k == 3) then
        Dk = 245
    end if
else if (l == 1 .and. lp == 3) then
    if (k == 2) then
        Dk = 175
    else if (k == 4) then
        Dk = 189
    end if
else if (l == 2 .and. lp == 2) then
    if (k == 0) then
        Dk = 1
    else if (k == 2) then
        Dk = 49
    else if (k == 4) then
        Dk = 441
    end if
else if (l == 2 .and. lp == 3) then
    if (k == 1) then
        Dk = 35
    else if (k == 3) then
        Dk = 315
    else if (k == 5) then
        Dk = 15246
    end if
else if (l == 3 .and. lp == 3) then
    if (k == 0) then
        Dk = 1
    else if (k == 2) then
        Dk = 225
    else if (k == 4) then
        Dk = 1089
    else if (k == 6) then
        Dk = 736164
    end if
end if
end function

integer function f(k, a) result(r)
integer, intent(in) :: k
real(dp), intent(in) :: a
real(dp) :: rr
if (abs(a) < tiny(1._dp)) then
    r = 0
else
    rr = abs(a) / a  * a**2 * Dk(k, l, lp)
    call assert(Dk(k, l, lp) /= 0)
    r = round(rr)
    ! This tests that the calculated value is 1e-10 from the exact integer:
    call assert(abs(r - rr) < 1e-10_dp)
end if
end function

integer pure function round(x) result(i)
real(dp), intent(in) :: x
if (abs(x) < tiny(1._dp)) then
    i = 0
else
    i = int(x + abs(x)/x * 0.5)
end if
end function

end program


      double complex function Lsm1DS(s,t,msq)
c--- This is an implementation of Eq. (B.2) from DS, 0906.0008
      implicit none
      include 'constants.f'
      double precision s,t,msq,r1,r2,omr1,omr2,ddilog
      double complex dilog1,dilog2,Lnrat
      r1=s/msq
      r2=t/msq
      omr1=one-r1
      omr2=one-r2
      if (omr1 .gt. one) then
       dilog1=dcmplx(pisqo6-ddilog(r1))
     & -Lnrat(-s,-msq)*dcmplx(log(omr1))
      else
       dilog1=dcmplx(ddilog(omr1))
      endif
      if (omr2 .gt. one) then
       dilog2=dcmplx(pisqo6-ddilog(r2))
     & -Lnrat(-t,-msq)*dcmplx(log(omr2))
      else
       dilog2=dcmplx(ddilog(omr2))
      endif
      Lsm1DS=dilog1+dilog2+Lnrat(-s,-msq)*Lnrat(-t,-msq)-dcmplx(pisqo6)
      return
      end


c     program DRDINTMR
c>> 2003-03-30 DRDINTMR Krogh Changed way of dealing with 0 denominator.
c>> 2001-05-22 DRDINTMR Krogh Minor change for making .f90 version.
c>> 1994-10-19 DRDINTMR Krogh  Changes to use M77CON
c>> 1994-08-31 DRDINTMR Snyder  Moved formats for C conversion
c>> 1994-08-08 DRDINTMR Snyder  Took '0' out of formats for C conversion
c>> 1991-11-20 CLL Edited for Fortran 90.
c>> 1987-12-09 DRDINTMR Snyder  Initial Code.
c--D replaces "?": DR?INTMR, ?INTM, ?INTMA, ?INTA
c
c     DEMO DRIVER for multi-dimensional quadrature subprogram DINTM.
c
c     Compute the integral for Y = 0.0 to Y = PI of
c             the integral for X = 0.0 to X = Y of
c             X * COS(Y) /(X*X+Y*Y).  The ANSWER should be zero.
c
c     The integrand and all limits are provided by reverse
c     communication.
c
c     This sample demonstrates the use of functional transformation of
c     the inner integral to reduce the cost of the overall computation.
c     The factor "cos y" does not depend on the variable of integration
c     for the inner integral, and therefore is factored out.  Similarly,
c     the term y*y in the denominator of the inner integrand is pre-
c     computed when the limits of the inner integral are requested.
c
c     This example also demonstrates the necessity to cope with overflow
c     of the integrand, even though the integral is well behaved.
c
      integer IFLAG, IOPT(10), NDIMI, NWPD, NWORK
      parameter (NDIMI=2, NWPD=217, NWORK=3*NDIMI+NWPD*(NDIMI-1))
      double precision ANSWER, WORK(NWORK)
      double precision COSY, DENOM, XDY, YSQ
c
10    format (/' DRDINTMR:'/
     1' Compute the integral for Y = 0.0 to Y = PI of'/
     2'         the integral for X = 0.0 to X = Y of'/
     3'         X * COS(Y) /(X*X+Y*Y).  The ANSWER should be zero.')
20    format (/' ANSWER =        ',G15.8/
     1         ' ERROR ESTIMATE =',G15.8/
     2         ' STATUS FLAG =   ',I3/
     3         ' FUNCTION VALUES (INNERMOST INTEGRALS) =',I6)
c
      print 10
      IOPT(2) = 10
      IOPT(3) = 0
      IOPT(4) = 6
      IOPT(5) = 0
      call DINTM (NDIMI, ANSWER, WORK, NWORK, IOPT)
 30   continue
      call DINTMA (ANSWER, WORK, IOPT)
      IFLAG = IOPT(1)
      if (IFLAG .eq. 0) then
c
c     IFLAG = 0, compute innermost integrand.
c
c     Iterate on the innermost integrand by calling DINTA here.
c     The code would be slightly simpler, but slightly slower,
c     if control of the iteration were relegated to DINTMA.
c
 40      continue
         DENOM = WORK(1) * WORK(1) + YSQ
         if (DENOM .ne. 0.0D0) then
c     This test will not detect overflow of the integrand if
c     the arithmetic underflows gradually.
            ANSWER = WORK(1) / DENOM
         else
c     Special care to avoid a zero denominator.
            XDY = WORK(1) / WORK(2)
            ANSWER = XDY / (WORK(2) * (1.D0 + XDY**2))
         end if
         call DINTA (ANSWER, WORK, IOPT)
         if(IOPT(1) .eq. 0) goto 40
c
         if (IOPT(1) .gt. 0) then
c                                 Done with the integration
            IOPT(1) = -(IOPT(1)+NDIMI)
            go to 60
         end if
c
      else if (IFLAG .eq. 1) then
c
c     Compute limits of inner dimension.
c
c   Set WORK(1) = COS(WORK(2)) = Partial derivative, with respect to
c   the integral over the inner dimension, of the transformation
c   applied when integration over the inner dimension is complete.
c   This is so dintm knows how much accuracy it needs for this integral.
c
         WORK(NDIMI+IFLAG) = 0.0D0
         WORK(2*NDIMI+IFLAG) = WORK(2)
         YSQ = WORK(2) * WORK(2)
         COSY = COS(WORK(2))
         WORK(1) = COSY
c
      else if (IFLAG .eq. 2) then
c
c     Compute limits of outer dimension.
c
         WORK(NDIMI+IFLAG) = 0.0D0
         WORK(2*NDIMI+IFLAG) = 4.0D0*ATAN(1.0D0)
c
      else
         if (IFLAG+NDIMI .le. 0) goto 60
c
c     IFLAG < 0, transform inner integrand.
c
         ANSWER = ANSWER * COSY
         WORK(1) = WORK(1) * COSY
c
      end if
      go to 30
c
60    continue

      print 20, ANSWER, WORK(1), IOPT(1), IOPT(3)
      stop
      end


c   The following routines implement all of the fitting formulae in
c   Eisenstein \& Hu (1997)
c
c   Program TF_fit: sample driver
c   Subroutine TFset_parameters(): sets all the scalar parameters
c   Subroutine TFtransfer_function(): calculates various transfer functions
c   Functions TF_zerobaryon, TF_nowiggles, sound_horizon_fit, kpeak,
c       alpha_gamma: implement various scaling approximations of \S 4.2
c
c
c ------------------------ DRIVER ROUTINE ---------------------------
c The following is a driver routines you might use.
c Basically, the driver routine asks for Omega_0, the baryon fraction,
c the hubble constant, and the CMB temperature, calls TFset_parameters() to
c set all the parameters of the fit.  A loop over wavenumbers kmin to an
c inputed kmax sampled at numk per decade calls TFtransfer_function.
c
c IMPORTANT: TFtransfer_function asks for wavenumbers in Mpc^{-1} so
c	     multiply by hubble to convert from h Mpc^{-1}
c
c The latter returns values of the various transfer functions at the given
c wavenumber which are output to the file "trans.dat"
c
c Also included is an example of how to call the functions
c
c	TF_nowiggles:	    shape approximation
c	TF_zerobaryon:      zero baryon TF
c	k_peak:		    approximate first peak location
c	sound_horizon_fit:  approximate sound horizon
c	alpha_gamma:  	    small scale modification to Gamma
c
c
c
c INPUT:  omega0 -- the matter density (baryons+CDM) in units of critical
c	  f_baryon -- the ratio of baryon density to matter density
c	  hubble -- the Hubble constant, in units of 100 km/s/Mpc
c	  Tcmb -- the CMB temperature in Kelvin.  2.728(4) is COBE and is the default
c	          reached by setting Tcmb=0.
c	  kmax -- maximum k in  h Mpc^{-1}
c	  numk -- number of k per decade
c
c OUTPUT: The file "trans.dat" with columns
c
c	 (1)  k -- wavenumber in h Mpc^{-1}
c	 (2)  tf_full -- The full fitting formula, eq. (16), for the matter
c			transfer function.
c	 (3)  tf_baryon -- The baryonic piece of the full fitting formula, eq. 21.
c	 (4)  tf_cdm -- The CDM piece of the full fitting formula, eq. 17.
c	 (5)  tf_nowiggles -- An approximate form, eqs. (30)-(31), that fits
c			only the non-oscillatory part of the transfer
c			function.  Appropriate only for low baryon fractions.
c	 (6)  tf_zerobaryon -- The transfer function of the zero-baryon case,
c			eq. (29); i.e. what would have occured were the
c			baryons CDM instead.
c
c	and the approximate values of k_peak,sound_horizon,alpha_gamma
c	to stdout, a more accurate form of sound_horizon lives in
c
c	GLOBALVARIABLES: Various intermediate fit parameters are stored in
c                        this common block for easy access.

c ----------------------------- DRIVER -------------------------------

       program TFfit

        real    omega0,f_baryon,hubble,Tcmb,kmax,kmin
	real	k,tf_full,tf_baryon,tf_cdm,tf_nowiggles,tf_zerobaryon,
     *		k_peak
	integer numk

c  cosmological parameters

	write(6,*) 'Omega_0,f_baryon,h,T_cmb?'
	read*,     omega0,f_baryon,hubble,Tcmb
	omhh = omega0*hubble*hubble

c  call routine to set fitting parameters

        call TFset_parameters(omhh, f_baryon, Tcmb)

c  loop over k, call subroutine and functions to calc TFs

	open(10,file='trans.dat')

	write(6,*) 'k_max (h Mpc^{-1}),#pts per decade (10,50)'
	read*,kmax,numk

	if (kmax.le.0) kmax=10.
	if (numk.le.0) numk=50

	kmin = 0.0001
	numk = numk*log10(kmax/kmin)

	do i=1,numk

	 k=10.**(i*(log10(kmax/kmin)/numk))*kmin
         call TFtransfer_function(k*hubble,omhh,f_baryon,
     &     tf_full,tf_baryon,tf_cdm)
	 write(10,50) k,tf_full,tf_baryon,tf_cdm,
     &               TF_nowiggles(k*hubble,omhh,f_baryon,Tcmb),
     &               TF_zerobaryon(k*hubble/omhh*(Tcmb/2.7)**2)

	end do

c  example of how to use the scaling functions

	write(6,*) 'Some useful approximate scalings:'

	write(6,10) k_peak(omhh,f_baryon)/hubble
10	FORMAT(1X,' First peak location (h Mpc^{-1}):  ',E13.4)
	write(6,20) sound_horizon_fit(omhh,f_baryon)*hubble
20	FORMAT(1X,' Approx. sound horizon (h^{-1} Mpc):',E13.4)
	write(6,30) alpha_gamma(omhh,f_baryon)
30	FORMAT(1X,' alpha_gamma:                       ',E13.4)

50	FORMAT(1X,7E13.5)

      end

c
c
c PART I:------------------- FITTING FORMULAE ROUTINES -----------------
c
c There are two routines and a set of functions.
c   TFset_parameters() sets all the scalar parameters, while
c   TFtransfer_function() calculates various transfer functions
c
c Global variables -- We've left many of the intermediate results as
c global variables in case you wish to access them, e.g. by declaring
c them as a common block in your main program.
c
c Note that all internal scales are in Mpc, without any Hubble constants!
c

	subroutine TFset_parameters(omhh,f_baryon,Tcmb)

	real y,omhh,obhh,Tcmb
	real theta_cmb,z_equality,k_equality,z_drag,R_drag,R_equality,
     &       sound_horizon,k_silk,alpha_c,beta_c,alpha_b,beta_b,
     &	     f_baryon,beta_node
	common/GLOBALVARIABLES/theta_cmb,z_equality,k_equality,z_drag,
     &       R_drag,R_equality,sound_horizon,k_silk,alpha_c,beta_c,
     &       alpha_b,beta_b,beta_node

c Set all the scalars quantities for Eisenstein & Hu 1997 fitting formula */
c Input omhh -- The density of CDM and baryons, in units of critical dens,
c                multiplied by the square of the Hubble constant, in units
c                of 100 km/s/Mpc */
c       f_baryon -- The fraction of baryons to CDM */
c       Tcmb -- The temperature of the CMB in Kelvin, 2.728(4) is COBE and is
c		the default reached by inputing Tcmb=0 -- reset on output. */
c Output nothing, but set many global variables in common block
c       GLOBALVARIABLES. You can access them yourself, if you want:
c
c	theta_cmb,	/* Tcmb in units of 2.7 K */
c	z_equality,	/* Redshift of matter-radiation equality, really 1+z */
c	k_equality,	/* Scale of equality, in Mpc^-1 */
c	z_drag,		/* Redshift of drag epoch */
c	R_drag,		/* Photon-baryon ratio at drag epoch */
c	R_equality,	/* Photon-baryon ratio at equality epoch */
c	sound_horizon,	/* Sound horizon at drag epoch, in Mpc */
c	k_silk,		/* Silk damping scale, in Mpc^-1 */
c	alpha_c,	/* CDM suppression */
c	beta_c,		/* CDM log shift */
c	alpha_b,	/* Baryon suppression */
c	beta_b,		/* Baryon envelope shift */

c Are inputs reasonable?

	if (f_baryon.le.0) f_baryon=1.e-5
	if (Tcmb.le.0) Tcmb=2.728
        if (omhh.le.0.0) then
	   write(6,*) 'TFset_parameters(): Illegal input'
	   pause
	end if

        if (hubble.gt.10.0) then
	   write(6,*) 'TFset_parameters(): WARNING, Hubble constant in
     &	               100km/s/Mpc desired'
	end if

c Auxiliary variables
        obhh = omhh*f_baryon
        theta_cmb = Tcmb/2.7

c Main variables
        z_equality = 2.50e4*omhh*theta_cmb**(-4.) - 1.D0
        k_equality = 0.0746*omhh*theta_cmb**(-2.)

          z_drag = 0.313*omhh**(-0.419)*(1.+0.607*omhh**(0.674))
          z_drag = 1e0 + z_drag*obhh**(0.238*omhh**(0.223))
        z_drag = 1291e0 * omhh**(0.251)/
     &           (1e0 + 0.659*omhh**(0.828)) * z_drag

        R_drag = 31.5*obhh*theta_cmb**(-4.)*1000e0/(1e0 + z_drag)
        R_equality = 31.5*obhh*theta_cmb**(-4.)
     &    	     *1000e0/(1e0 + z_equality)

        sound_horizon = 2./3./k_equality*sqrt(6./R_equality)*
     &	    log(( sqrt(1.+R_drag)+sqrt(R_drag+R_equality) )
     &       /(1.+sqrt(R_equality)))

        k_silk = 1.6*obhh**(0.52)*omhh**(0.73)*
     &           (1e0 + (10.4*omhh)**(-0.95))

          alpha_c = ((46.9*omhh)**(0.670)*(1e0+(32.1*omhh)**(-0.532)))
          alpha_c = alpha_c**(-f_baryon)
	alpha_c = alpha_c*((12.0*omhh)**(0.424)*(1e0 +
     &             (45.0*omhh)**(-0.582)))**(-f_baryon**3.)

          beta_c = 0.944/(1+(458.*omhh)**(-0.708))
          beta_c = 1.+beta_c*((1.-f_baryon)**((0.395*omhh)**(-0.0266))
     &    	- 1e0)
	  beta_c = 1./beta_c

          y = (1e0+z_equality)/(1e0+z_drag)
          alpha_b = y*(-6.*sqrt(1.+y)+(2.+3.*y)*log((sqrt(1.+y)+1.)
     &   	    /(sqrt(1.+y)-1.)))
        alpha_b = 2.07*k_equality*sound_horizon*
     &            (1.+R_drag)**(-0.75)*alpha_b

        beta_b = 0.5+f_baryon+(3.-2.*f_baryon)*
     &           sqrt((17.2*omhh)**2.+1e0)

        beta_node = 8.41*omhh**(0.435)

        return

        end

        subroutine TFtransfer_function(k,omhh,f_baryon,tf_full,
     &                tf_baryon,tf_cdm)

c  Calculate transfer function from the fitting parameters stored in
c  GLOBALVARIABLES.
c
c  Input:
c	 k -- wavenumber in Mpc^{-1}
c        omhh -- The density of CDM and baryons, in units of critical dens,
c                multiplied by the square of the Hubble constant, in units
c                of 100 km/s/Mpc */
c        f_baryon -- The fraction of baryons to CDM */
c
c  Output:
c	 tf_full -- The full fitting formula, eq. (16), for the matter
c	            transfer function.
c	 tf_baryon -- The baryonic piece of the full fitting formula, eq. 21.
c	 tf_cdm -- The CDM piece of the full fitting formula, eq. 17.
c

	real k,tf_full,tf_baryon,tf_cdm,q,ks
	real theta_cmb,z_equality,k_equality,z_drag,R_drag,R_equality,
     &       sound_horizon,k_silk,alpha_c,beta_c,alpha_b,beta_b,
     &	     f_baryon,beta_node
	common/GLOBALVARIABLES/theta_cmb,z_equality,k_equality,z_drag,
     &       R_drag,R_equality,sound_horizon,k_silk,alpha_c,beta_c,
     &       alpha_b,beta_b,beta_node

c  Reasonable k?

        if (k.le.0) then
           write(6,*) 'TFtransfer_function(): Illegal k'
           pause
        end if

c  Auxiliary Variables

	    q = k/13.41/k_equality
	    ks = k*sound_horizon

c  Main Variables

              tf_cdm = 1./(1.+(ks/5.4)**4.)
	    tf_cdm = tf_cdm*TF_pressureless(q,1.,beta_c) +
     &           (1.-tf_cdm)*TF_pressureless(q,alpha_c,beta_c)

	      s_tilde = sound_horizon/(1.+(beta_node/ks)**3.)**(1./3.)
	      tf_baryon = TF_pressureless(q,1.,1.)/(1.+(ks/5.2)**2.)
	      tf_baryon = tf_baryon + alpha_b/(1.+(beta_b/ks)**3)
     &                       *exp(-(k/k_silk)**(1.4))
	      tf_baryon = tf_baryon *(sin(k*s_tilde)/(k*s_tilde))
	    tf_full = f_baryon*tf_baryon + (1-f_baryon)*tf_cdm

         return

	 end

c       auxiliary function: Pressureless TF

	real function TF_pressureless(q,a,b)

	  real q,a,b

	  TF_pressureless = Log(exp(1.)+1.8*b*q)
	  TF_pressureless = TF_pressureless/(TF_pressureless +
     &                      (14.2/a + 386/(1.+69.9*q**1.08))*q**2)

	  return

	end
c
c
c
c
c
c
c PART II:------------------- Scaling Functions ROUTINES -----------------
c
c       omhh -- The density of CDM and baryons, in units of critical dens,
c                multiplied by the square of the Hubble constant, in units
c                of 100 km/s/Mpc */
c       f_baryon -- The fraction of baryons to CDM */
c
c
c	TF_zerobaryon:
c	  Input:  q = k/omhh * (Tcmb/2.7)**2    (k in Mpc^{-1})
c	  Output: zero baryon TF Eq(29)
c	TF_nowiggles:
c	  Input:  k = wavenumber in Mpc^{-1}, omhh, f_baryon, Tcmb
c	  Output: shape approximation TF  Eq(30-31)
c	  Calls: TF_zerobaryon,sound_horizon_fit,alpha_gamma
c 	sound_horizon_fit:
c         Input:  omhh,f_baryon
c	  Output: approximate sound horizon in Mpc
c	kpeak:
c	  Input:  omhh,f_baryon
c         Output: first peak location in Mpc
c	  Calls:  sound_horizon_fit
c	alpha_gamma:
c	  Input: omhh,f_baryon
c	  Output: effective small scale suppression

	real function TF_zerobaryon(q)

	  real q
	  TF_zerobaryon = log(2.0*exp(1.)+1.8*q)
	  TF_zerobaryon = TF_zerobaryon/(TF_zerobaryon
     &                    +(14.2 + 731.0/(1+62.5*q))*q**2)

	  return

	end

	real function TF_nowiggles(k,omhh,f_baryon,Tcmb)

	  real k,omhh,f_baryon,q_eff,a

	    if (Tcmb.le.0) Tcmb=2.728
	    a = alpha_gamma(omhh,f_baryon)
	    q_eff = k/omhh*(Tcmb/2.7)**2
	    q_eff = q_eff/(a+(1.-a)/
     &              (1.+(0.43*k*sound_horizon_fit(omhh,f_baryon))**4))

	    TF_nowiggles = TF_zerobaryon(q_eff)

	  return
        end

	real function sound_horizon_fit(omhh,f_baryon)

	 real omhh,obhh,f_baryon
	 obhh = f_baryon*omhh
         sound_horizon_fit = 44.5*log(9.83/omhh)
     &                      /sqrt(1.+10.0*obhh**(0.75))

	return
	end

	real function k_peak(omhh,f_baryon)

	 real omhh,obhh,f_baryon
	 obhh = f_baryon*omhh
         k_peak = 5.*3.14159/2.*(1.+0.217*omhh)/
     &             sound_horizon_fit(omhh,f_baryon)

	 return
	end

	real function alpha_gamma(omhh,f_baryon)

	 real omhh,f_baryon

         alpha_gamma = 1.-0.328*log(431.0*omhh)*f_baryon
     &                + 0.38*log(22.3*omhh)*(f_baryon)**2

	 return
	end