*DECK SEPELI
      SUBROUTINE SEPELI (INTL, IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB,
     +   BETA, C, D, N, NBDCND, BDC, GAMA, BDD, XNU, COFX, COFY, GRHS,
     +   USOL, IDMN, W, PERTRB, IERROR)
C***BEGIN PROLOGUE  SEPELI
C***PURPOSE  Discretize and solve a second and, optionally, a fourth
C            order finite difference approximation on a uniform grid to
C            the general separable elliptic partial differential
C            equation on a rectangle with any combination of periodic or
C            mixed boundary conditions.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A2
C***TYPE      SINGLE PRECISION (SEPELI-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C Dimension of           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C Arguments              USOL(IDMN,N+1), GRHS(IDMN,N+1),
C                        W (see argument list)
C
C Latest Revision        March 1977
C
C Purpose                SEPELI solves for either the second-order
C                        finite difference approximation or a
C                        fourth-order approximation to a separable
C                        elliptic equation.
C
C                                    2    2
C                             AF(X)*d U/dX + BF(X)*dU/dX  + CF(X)*U +
C                                    2    2
C                             DF(Y)*d U/dY  + EF(Y)*dU/dY + FF(Y)*U
C
C                             = G(X,Y)
C
C                        on a rectangle (X greater than or equal to A
C                        and less than or equal to B; Y greater than
C                        or equal to C and less than or equal to D).
C                        Any combination of periodic or mixed boundary
C                        conditions is allowed.
C
C Purpose                The possible boundary conditions are:
C                        in the X-direction:
C                         (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X
C                         (1) U(A,Y), U(B,Y) are specified for all Y
C                         (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are
C                             specified for all Y
C                         (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+
C                             BETA*U(B,Y) are specified for all Y
C                         (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are
C                             specified for all Y
C
C                        in the Y-direction:
C                         (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y
C                         (1) U(X,C),U(X,D) are specified for all X
C                         (2) U(X,C),dU(X,D)/dY+XNU*U(X,D) are specified
C                             for all X
C                         (3) dU(X,C)/dY+GAMA*U(X,C),dU(X,D)/dY+
C                             XNU*U(X,D) are specified for all X
C                         (4) dU(X,C)/dY+GAMA*U(X,C),U(X,D) are
C                             specified for all X
C
C Arguments
C
C On Input               INTL
C                          = 0 On initial entry to SEPELI or if any of
C                              the arguments C, D, N, NBDCND, COFY are
C                              changed from a previous call
C                          = 1 If C, D, N, NBDCND, COFY are unchanged
C                              from the previous call.
C
C                        IORDER
C                          = 2 If a second-order approximation is sought
C                          = 4 If a fourth-order approximation is sought
C
C                        A,B
C                          The range of the X-independent variable;
C                          i.e., X is greater than or equal to A and
C                          less than or equal to B.  A must be less than
C                          B.
C
C                        M
C                          The number of panels into which the interval
C                          [A,B] is subdivided.  Hence, there will be
C                          M+1 grid points in the X-direction given by
C                          XI=A+(I-1)*DLX for I=1,2,...,M+1 where
C                          DLX=(B-A)/M is the panel width.  M must be
C                          less than IDMN and greater than 5.
C
C                        MBDCND
C                          Indicates the type of boundary condition at
C                          X=A and X=B
C                          = 0 If the solution is periodic in X; i.e.,
C                              U(X+B-A,Y)=U(X,Y) for all Y,X
C                          = 1 If the solution is specified at X=A and
C                              X=B; i.e., U(A,Y) and U(B,Y) are
C                              specified for all Y
C                          = 2 If the solution is specified at X=A and
C                              the boundary condition is mixed at X=B;
C                              i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y)
C                              are specified for all Y
C                          = 3 If the boundary conditions at X=A and X=B
C                              are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y)
C                              and dU(B,Y)/dX+BETA*U(B,Y) are specified
C                              for all Y
C                          = 4 If the boundary condition at X=A is mixed
C                              and the solution is specified at X=B;
C                              i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y)
C                              are specified for all Y
C
C                        BDA
C                          A one-dimensional array of length N+1 that
C                          specifies the values of dU(A,Y)/dX+
C                          ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4.
C                               BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ);
C                               J=1,2,...,N+1
C                          when MBDCND has any other value, BDA is a
C                          dummy parameter.
C
C On Input               ALPHA
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition at X=A (see
C                          argument BDA).  If MBDCND = 3,4 then ALPHA is
C                          a dummy parameter.
C
C                        BDB
C                          A one-dimensional array of length N+1 that
C                          specifies the values of dU(B,Y)/dX+
C                          BETA*U(B,Y) at X=B.  When MBDCND=2 or 3
C                               BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ);
C                               J=1,2,...,N+1
C                          When MBDCND has any other value, BDB is a
C                          dummy parameter.
C
C                        BETA
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition at X=B (see
C                          argument BDB).  If MBDCND=2,3 then BETA is a
C                          dummy parameter.
C
C                        C,D
C                          The range of the Y-independent variable;
C                          i.e., Y is greater than or equal to C and
C                          less than or equal to D.  C must be less than
C                          D.
C
C                        N
C                          The number of panels into which the interval
C                          [C,D] is subdivided.  Hence, there will be
C                          N+1 grid points in the Y-direction given by
C                          YJ=C+(J-1)*DLY for J=1,2,...,N+1 where
C                          DLY=(D-C)/N is the panel width.  In addition,
C                          N must be greater than 4.
C
C                        NBDCND
C                          Indicates the types of boundary conditions at
C                          Y=C and Y=D
C                          = 0 If the solution is periodic in Y; i.e.,
C                              U(X,Y+D-C)=U(X,Y) for all X,Y
C                          = 1 If the solution is specified at Y=C and
C                              Y = D, i.e., U(X,C) and U(X,D) are
C                              specified for all X
C                          = 2 If the solution is specified at Y=C and
C                              the boundary condition is mixed at Y=D;
C                              i.e., U(X,C) and dU(X,D)/dY+XNU*U(X,D)
C                              are specified for all X
C                          = 3 If the boundary conditions are mixed at
C                              Y=C and Y=D; i.e., dU(X,D)/dY+GAMA*U(X,C)
C                              and dU(X,D)/dY+XNU*U(X,D) are specified
C                              for all X
C                          = 4 If the boundary condition is mixed at Y=C
C                              and the solution is specified at Y=D;
C                              i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D)
C                              are specified for all X
C
C                        BDC
C                          A one-dimensional array of length M+1 that
C                          specifies the value of dU(X,C)/dY+GAMA*U(X,C)
C                          at Y=C.  When NBDCND=3 or 4
C                             BDC(I) = dU(XI,C)/dY + GAMA*U(XI,C);
C                             I=1,2,...,M+1.
C                          When NBDCND has any other value, BDC is a
C                          dummy parameter.
C
C                        GAMA
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition at Y=C (see
C                          argument BDC).  If NBDCND=3,4 then GAMA is a
C                          dummy parameter.
C
C                        BDD
C                          A one-dimensional array of length M+1 that
C                          specifies the value of dU(X,D)/dY +
C                          XNU*U(X,D) at Y=C.  When NBDCND=2 or 3
C                            BDD(I) = dU(XI,D)/dY + XNU*U(XI,D);
C                            I=1,2,...,M+1.
C                          When NBDCND has any other value, BDD is a
C                          dummy parameter.
C
C                        XNU
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition at Y=D (see
C                          argument BDD).  If NBDCND=2 or 3 then XNU is
C                          a dummy parameter.
C
C                        COFX
C                          A user-supplied subprogram with
C                          parameters X, AFUN, BFUN, CFUN which
C                          returns the values of the X-dependent
C                          coefficients AF(X), BF(X), CF(X) in
C                          the elliptic equation at X.
C
C                        COFY
C                          A user-supplied subprogram with
C                          parameters Y, DFUN, EFUN, FFUN which
C                          returns the values of the Y-dependent
C                          coefficients DF(Y), EF(Y), FF(Y) in
C                          the elliptic equation at Y.
C
C                        NOTE:  COFX and COFY must be declared external
C                        in the calling routine.  The values returned in
C                        AFUN and DFUN must satisfy AFUN*DFUN greater
C                        than 0 for A less than X less than B,
C                        C less than Y less than D (see IERROR=10).
C                        The coefficients provided may lead to a matrix
C                        equation which is not diagonally dominant in
C                        which case solution may fail (see IERROR=4).
C
C                        GRHS
C                          A two-dimensional array that specifies the
C                          values of the right-hand side of the elliptic
C                          equation; i.e., GRHS(I,J)=G(XI,YI), for
C                          I=2,...,M; J=2,...,N.  At the boundaries,
C                          GRHS is defined by
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          where * means these quantities are not used.
C                          GRHS should be dimensioned IDMN by at least
C                          N+1 in the calling routine.
C
C                        USOL
C                          A two-dimensional array that specifies the
C                          values of the solution along the boundaries.
C                          At the boundaries, USOL is defined by
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          where * means the quantities are not used in
C                          the solution.
C
C                          If IORDER=2, the user may equivalence GRHS
C                          and USOL to save space.  Note that in this
C                          case the tables specifying the boundaries of
C                          the GRHS and USOL arrays determine the
C                          boundaries uniquely except at the corners.
C                          If the tables call for both G(X,Y) and
C                          U(X,Y) at a corner then the solution must be
C                          chosen.  For example, if MBDCND=2 and
C                          NBDCND=4, then U(A,C), U(A,D), U(B,D) must be
C                          chosen at the corners in addition to G(B,C).
C
C                          If IORDER=4, then the two arrays, USOL and
C                          GRHS, must be distinct.
C
C                          USOL should be dimensioned IDMN by at least
C                          N+1 in the calling routine.
C
C                        IDMN
C                          The row (or first) dimension of the arrays
C                          GRHS and USOL as it appears in the program
C                          calling SEPELI.  This parameter is used to
C                          specify the variable dimension of GRHS and
C                          USOL.  IDMN must be at least 7 and greater
C                          than or equal to M+1.
C
C                        W
C                          A one-dimensional array that must be provided
C                          by the user for work space.  Let
C                          K=INT(log2(N+1))+1 and set  L=2**(K+1).
C                          then (K-2)*L+K+10*N+12*M+27 will suffice
C                          as a length of W.  THE actual length of W in
C                          the calling routine must be set in W(1) (see
C                          IERROR=11).
C
C On Output              USOL
C                          Contains the approximate solution to the
C                          elliptic equation.  USOL(I,J) is the
C                          approximation to U(XI,YJ) for I=1,2...,M+1
C                          and J=1,2,...,N+1.  The approximation has
C                          error O(DLX**2+DLY**2) if called with
C                          IORDER=2 and O(DLX**4+DLY**4) if called with
C                          IORDER=4.
C
C                        W
C                          Contains intermediate values that must not be
C                          destroyed if SEPELI is called again with
C                          INTL=1.  In addition W(1) contains the exact
C                          minimal length (in floating point) required
C                          for the work space (see IERROR=11).
C
C                        PERTRB
C                          If a combination of periodic or derivative
C                          boundary conditions (i.e., ALPHA=BETA=0 if
C                          MBDCND=3; GAMA=XNU=0 if NBDCND=3) is
C                          specified and if the coefficients of U(X,Y)
C                          in the separable elliptic equation are zero
C                          (i.e., CF(X)=0 for X greater than or equal to
C                          A and less than or equal to B; FF(Y)=0 for
C                          Y greater than or equal to C and less than
C                          or equal to D) then a solution may not exist.
C                          PERTRB is a constant calculated and
C                          subtracted from the right-hand side of the
C                          matrix equations generated by SEPELI which
C                          insures that a solution exists.  SEPELI then
C                          computes this solution which is a weighted
C                          minimal least squares solution to the
C                          original problem.
C
C                        IERROR
C                          An error flag that indicates invalid input
C                          parameters or failure to find a solution
C                          = 0 No error
C                          = 1 If A greater than B or C greater than D
C                          = 2 If MBDCND less than 0 or MBDCND greater
C                              than 4
C                          = 3 If NBDCND less than 0 or NBDCND greater
C                              than 4
C                          = 4 If attempt to find a solution fails.
C                              (the linear system generated is not
C                              diagonally dominant.)
C                          = 5 If IDMN is too small (see discussion of
C                              IDMN)
C                          = 6 If M is too small or too large (see
C                              discussion of M)
C                          = 7 If N is too small (see discussion of N)
C                          = 8 If IORDER is not 2 or 4
C                          = 9 If INTL is not 0 or 1
C                          = 10 If AFUN*DFUN less than or equal to 0 for
C                               some interior mesh point (XI,YJ)
C                          = 11 If the work space length input in W(1)
C                               is less than the exact minimal work
C                               space length required output in W(1).
C
C                          NOTE (concerning IERROR=4):  for the
C                          coefficients input through COFX, COFY, the
C                          discretization may lead to a block
C                          tridiagonal linear system which is not
C                          diagonally dominant (for example, this
C                          happens if CFUN=0 and BFUN/(2.*DLX) greater
C                          than AFUN/DLX**2).  In this case solution may
C                          fail.  This cannot happen in the limit as
C                          DLX, DLY approach zero.  Hence, the condition
C                          may be remedied by taking larger values for M
C                          or N.
C
C Entry Points           SEPELI, SPELIP, CHKPRM, CHKSNG, ORTHOG, MINSOL,
C                        TRISP, DEFER, DX, DY, BLKTRI, BLKTR1, INDXB,
C                        INDXA, INDXC, PROD, PRODP, CPROD, CPRODP,
C                        PPADD, PSGF, BSRH, PPSGF, PPSPF, COMPB,
C                        TRUN1, STOR1, TQLRAT
C
C Special Conditions     NONE
C
C Common Blocks          SPLP, CBLKT
C
C I/O                    NONE
C
C Precision              Single
C
C Specialist             John C. Adams, NCAR, Boulder, Colorado  80307
C
C Language               FORTRAN
C
C History                Developed at NCAR during 1975-76.
C
C Algorithm              SEPELI automatically discretizes the separable
C                        elliptic equation which is then solved by a
C                        generalized cyclic reduction algorithm in the
C                        subroutine, BLKTRI.  The fourth-order solution
C                        is obtained using 'Deferred Corrections' which
C                        is described and referenced in sections,
C                        references and method.
C
C Space Required         14654 (octal) = 6572 (decimal)
C
C Accuracy and Timing    The following computational results were
C                        obtained by solving the sample problem at the
C                        end of this write-up on the Control Data 7600.
C                        The op count is proportional to M*N*log2(N).
C                        In contrast to the other routines in this
C                        chapter, accuracy is tested by computing and
C                        tabulating second- and fourth-order
C                        discretization errors.  Below is a table
C                        containing computational results.  The times
C                        given do not include initialization (i.e.,
C                        times are for INTL=1).  Note that the
C                        fourth-order accuracy is not realized until the
C                        mesh is sufficiently refined.
C
C              Second-order    Fourth-order   Second-order  Fourth-order
C    M    N   Execution Time  Execution Time    Error         Error
C               (M SEC)         (M SEC)
C     6    6         6              14          6.8E-1        1.2E0
C    14   14        23              58          1.4E-1        1.8E-1
C    30   30       100             247          3.2E-2        9.7E-3
C    62   62       445           1,091          7.5E-3        3.0E-4
C   126  126     2,002           4,772          1.8E-3        3.5E-6
C
C Portability            There are no machine-dependent constants.
C
C Required Resident      SQRT, ABS, LOG
C Routines
C
C References             Keller, H.B., 'Numerical Methods for Two-point
C                          Boundary-value Problems', Blaisdel (1968),
C                          Waltham, Mass.
C
C                        Swarztrauber, P., and R. Sweet (1975):
C                          'Efficient FORTRAN Subprograms for The
C                          Solution of Elliptic Partial Differential
C                          Equations'.  NCAR Technical Note
C                          NCAR-TN/IA-109, pp. 135-137.
C
C***REFERENCES  H. B. Keller, Numerical Methods for Two-point
C                 Boundary-value Problems, Blaisdel, Waltham, Mass.,
C                 1968.
C               P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  CHKPRM, SPELIP
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SEPELI
C
      DIMENSION       GRHS(IDMN,*)           ,USOL(IDMN,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      EXTERNAL        COFX       ,COFY
C***FIRST EXECUTABLE STATEMENT  SEPELI
      CALL CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY,
     1             IDMN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      LOGB2N = INT(LOG(L+0.5)/LOG(2.0))+1
      LL = 2**(LOGB2N+1)
      K = M+1
      L = N+1
      LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX(2*L,6*K)+5
      IF (NBDCND .EQ. 0) LENGTH = LENGTH+2*L
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = LOUTPT
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SPELIP (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1             NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END


module mdft_coulomb_solvers
  implicit none
  private
  public :: solve_coulomb
contains

  subroutine solve_coulomb ( Nsource, source_coo, source_charge, Ntarget, target_coo, target_electric_field, method )
    implicit none
    integer, intent(in) :: Nsource
    double precision, intent(in) :: source_coo(3,Nsource) ! coordinates of sources
    double precision, intent(in) :: source_charge(Nsource) ! the charge of each source in electron units
    integer, intent(in) :: Ntarget
    double precision, intent(in) :: target_coo(3,Ntarget) ! target coordinates
    double precision, intent(out) :: target_electric_field(Ntarget) ! what we are looking for : the electric field at target coordinates
    integer, intent(in) :: method ! 0 for direct sum
    integer :: itarget, isource

    !
    ! At this point the target_electric_field is unknown. Initialization:
    !
    target_electric_field = 0.d0

    select case (method)

    case (0) ! direct sum

      do itarget=1,Ntarget
        do isource=1,Nsource
          target_electric_field(itarget) = target_electric_field(itarget) + source_charge(isource) &
             / norm2(source_coo(:,isource) - target_coo(:,itarget))  ! electric_field(target) = sum_sources ( qsource/r)
        end do
      end do

    case default
      print*, "In module mdft_coulomb_solver, method", method," is not implemented"
      error stop "KLXZkbh7jdMpkj5Z"
    end select

  end subroutine solve_coulomb

end module mdft_coulomb_solvers


C
C $Id: idlsqf.f,v 1.4 2008-07-27 00:17:30 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE IDLSQF (X,Y,Z,N,A,B,C,XAVG,YAVG)
C
        DIMENSION X(N),Y(N),Z(N)
C
C IDLSQF fits a plane to the data defined by points (X(I),Y(I),Z(I)),
C for I from 1 to N.  It returns the coefficients A, B, and C in the
C equation "Z=AX+BY+C".  It also returns the average X and average Y.
C
        SA=0.
        SB=0.
        SC=0.
        SD=0.
        SE=0.
        SF=0.
        SG=0.
        SH=0.
C
        DO 101 I=1,N
          SA=SA+X(I)
          SB=SB+Y(I)
          SC=SC+Z(I)
          SD=SD+X(I)*X(I)
          SE=SE+Y(I)*Y(I)
          SF=SF+X(I)*Y(I)
          SG=SG+Y(I)*Z(I)
          SH=SH+X(I)*Z(I)
  101   CONTINUE
C
        RN=REAL(N)
C
        A=((RN*SH-SA*SC)*(RN*SE-SB*SB)-(RN*SF-SA*SB)*(RN*SG-SB*SC))/
     +    ((RN*SD-SA*SA)*(RN*SE-SB*SB)-(RN*SF-SA*SB)*(RN*SF-SA*SB))
        B=((RN*SD-SA*SA)*(RN*SG-SB*SC)-(RN*SF-SA*SB)*(RN*SH-SA*SC))/
     +    ((RN*SD-SA*SA)*(RN*SE-SB*SB)-(RN*SF-SA*SB)*(RN*SF-SA*SB))
        C=(SC-SA*A-SB*B)/RN
C
        XAVG=SA/RN
        YAVG=SB/RN
C
C Done.
C
        RETURN
C
      END


!this module is used to calculate the M and h in the CSI
!this module have a function to calculate f[x1,x2,x3]
MODULE csi_mod
    USE threediag_mod
    IMPLICIT NONE
    PRIVATE
    PUBLIC::CSI
CONTAINS
    SUBROUTINE CSI(n_in,x,y,condition,a_in,b_in,M,h)
        INTEGER(4),INTENT(IN):: n_in
        REAL(8),DIMENSION(:),INTENT(IN)::x(n_in),y(n_in)
        CHARACTER(10),INTENT(IN)::condition
        REAL(8),INTENT(IN)::a_in,b_in
        REAL(8),ALLOCATABLE::miu(:),lamda(:),d(:)
        REAL(8),DIMENSION(:),INTENT(OUT)::M(n_in),h(n_in-1)
        REAL(8),ALLOCATABLE::a_three(:),b_three(:),c_three(:),d_three(:),M_three(:)
        INTEGER(4)::i
        M=0
        h=0
        ALLOCATE(miu(n_in-2))
        ALLOCATE(lamda(n_in-2))
        ALLOCATE(d(n_in))
        miu=0
        lamda=0
        d=0
        DO i=2,n_in
            h(i-1)=x(i)-x(i-1) !calculate h
        END DO
        DO i=2,n_in-1
            d(i)=6*diff3(x(i-1),x(i),x(i+1),y(i-1),y(i),y(i+1))
        END DO
        DO i=1,n_in-2
            miu(i)=h(i)/(h(i)+h(i+1))
            lamda(i)=1-miu(i)
        END DO
        SELECT CASE(condition)
            CASE('first') !the first condition
                M(1)=a_in
                M(n_in)=b_in
                d(2)=d(2)-miu(1)*M(1)
                d(n_in-1)=d(n_in-1)-lamda(n_in-1)*M(n_in)
                ALLOCATE(a_three(n_in-2))
                ALLOCATE(b_three(n_in-2))
                ALLOCATE(c_three(n_in-2))
                ALLOCATE(d_three(n_in-2))
                ALLOCATE(M_three(n_in-2)) !define a,b,c,d,m to use the threediag Ax=b
                a_three=0
                b_three=2     !b=2
                c_three=0
                d_three=0
                M_three=0
                c_three(1)=lamda(1)
                d_three(1)=d(2)
                a_three(n_in-2)=miu(n_in-2)
                d_three(n_in-2)=d(n_in-1)
                DO i=2,n_in-3
                    a_three(i)=miu(i)
                    c_three(i)=lamda(i)
                    d_three(i)=d(i+1)
                END DO
                CALL threediag(n_in-2,a_three,b_three,c_three,d_three,&
                                M_three)
                DO i=1,n_in-2
                    M(i+1)=M_three(i) !get the M
                END DO
                DEALLOCATE(a_three)
                DEALLOCATE(b_three)
                DEALLOCATE(c_three)
                DEALLOCATE(d_three)
                DEALLOCATE(M_three)
            CASE('second') !the second condition
                d(1)=(6/h(1))*((y(2)-y(1))/h(1)-a_in)
                d(n_in)=(6/h(n_in-1))*(b_in-(y(n_in)-y(n_in-1))/h(n_in-1))
                ALLOCATE(a_three(n_in))
                ALLOCATE(b_three(n_in))
                ALLOCATE(c_three(n_in))!define a,b,c to use the threediag Ax=b
                a_three=0
                b_three=2     !b=2
                c_three=0
                c_three(1)=1
                a_three(n_in)=1
                DO i=2,n_in-1
                    a_three(i)=miu(i-1)
                    c_three(i)=lamda(i-1)
                END DO
                CALL threediag(n_in,a_three,b_three,c_three,d,&
                                M)
                DEALLOCATE(a_three)
                DEALLOCATE(b_three)
                DEALLOCATE(c_three)
            CASE('third')
                ALLOCATE(a_three(n_in-1))
                ALLOCATE(b_three(n_in-1))
                ALLOCATE(c_three(n_in-1))!define a,b,c,d,m to use the threediag Ax=b
                b_three=2
                a_three(1:n_in-2)=miu(1:n_in-2)
                c_three(1:n_in-2)=lamda(1:n_in-2)
                a_three(n_in-1)=h(n_in-1)/(h(n_in-1)+h(1))
                c_three(n_in-1)=1-a_three(n_in-1)
                d(n_in)=(6/(h(n_in-1)+h(1)))*((y(2)-y(n_in))/h(1)-(y(n_in)-y(n_in-1))/h(n_in-1))
                ALLOCATE(d_three(n_in-1))
                ALLOCATE(M_three(n_in-1))
                d_three(1:n_in-1)=d(2:n_in)
                CALL boundary3(n_in-1,a_three,b_three,c_three,&
                                d_three,M_three)
                M(2:n_in)=M_three(1:n_in-1)
                M(1)=M_three(n_in-1)
                DEALLOCATE(a_three)
                DEALLOCATE(b_three)
                DEALLOCATE(c_three)
                DEALLOCATE(d_three)
                DEALLOCATE(M_three)
            END SELECT
            DEALLOCATE(miu)
            DEALLOCATE(lamda)
            DEALLOCATE(d)
    END SUBROUTINE
    SUBROUTINE boundary3(n,a,b,c,d,x)
        INTEGER(4),INTENT(IN)::n
        REAL(8),DIMENSION(:),INTENT(IN)::a(n),b(n),c(n),d(n)
        REAL(8),DIMENSION(:),INTENT(INOUT)::x(n)
        REAL(8),ALLOCATABLE::u(:),l(:),y(:)
        INTEGER(4)::i
        ALLOCATE(y(n))
        ALLOCATE(u(n))
        ALLOCATE(l(n))
        x=0
        y=0
        u=0
        l=0
        u(1)=b(1)
        y(1)=d(1)
        l(1)=a(1)
        u(n)=c(n)/u(1)
        DO i=2,n
            l(i)=a(i)/u(i-1)
            u(i)=b(i)-l(i)*c(i-1)
            y(i)=d(i)-l(i)*y(i-1)
        END DO
        y(n)=y(n)-u(n)*l(1)
        x(n)=y(n)/u(n)
        DO i=n-1,2,-1
            x(i)=(y(i)-c(i)*x(i+1))/u(i)
        END DO
        x(1)=(y(1)-c(2)*x(2)-l(1)*x(n))/u(1)
        DEALLOCATE(y)
        DEALLOCATE(u)
        DEALLOCATE(l)
    END SUBROUTINE

    FUNCTION diff3(x1,x2,x3,y1,y2,y3)
        REAL(8),INTENT(IN)::x1,x2,x3
        REAL(8),INTENT(IN)::y1,y2,y3
        REAL(8)::f1,f2,diff3
        f1=(y2-y1)/(x2-x1)
        f2=(y3-y2)/(x3-x2)
        diff3=(f2-f1)/(x3-x1)
    END FUNCTION
END MODULE


*DECK DEFC
      SUBROUTINE DEFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT,
     +   MDEIN, MDEOUT, COEFF, LW, W)
C***BEGIN PROLOGUE  DEFC
C***PURPOSE  Fit a piecewise polynomial curve to discrete data.
C            The piecewise polynomials are represented as B-splines.
C            The fitting is done in a weighted least squares sense.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A1, K1A2A, L8A3
C***TYPE      DOUBLE PRECISION (EFC-S, DEFC-D)
C***KEYWORDS  B-SPLINE, CONSTRAINED LEAST SQUARES, CURVE FITTING
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C      This subprogram fits a piecewise polynomial curve
C      to discrete data.  The piecewise polynomials are
C      represented as B-splines.
C      The fitting is done in a weighted least squares sense.
C
C      The data can be processed in groups of modest size.
C      The size of the group is chosen by the user.  This feature
C      may be necessary for purposes of using constrained curve fitting
C      with subprogram DFC( ) on a very large data set.
C
C      For a description of the B-splines and usage instructions to
C      evaluate them, see
C
C      C. W. de Boor, Package for Calculating with B-Splines.
C                     SIAM J. Numer. Anal., p. 441, (June, 1977).
C
C      For further discussion of (constrained) curve fitting using
C      B-splines, see
C
C      R. J. Hanson, Constrained Least Squares Curve Fitting
C                   to Discrete Data Using B-Splines, a User's
C                   Guide. Sandia Labs. Tech. Rept. SAND-78-1291,
C                   December, (1978).
C
C  Input.. All TYPE REAL variables are DOUBLE PRECISION
C      NDATA,XDATA(*),
C      YDATA(*),
C      SDDATA(*)
C                         The NDATA discrete (X,Y) pairs and the Y value
C                         standard deviation or uncertainty, SD, are in
C                         the respective arrays XDATA(*), YDATA(*), and
C                         SDDATA(*).  No sorting of XDATA(*) is
C                         required.  Any non-negative value of NDATA is
C                         allowed.  A negative value of NDATA is an
C                         error.  A zero value for any entry of
C                         SDDATA(*) will weight that data point as 1.
C                         Otherwise the weight of that data point is
C                         the reciprocal of this entry.
C
C      NORD,NBKPT,
C      BKPT(*)
C                         The NBKPT knots of the B-spline of order NORD
C                         are in the array BKPT(*).  Normally the
C                         problem data interval will be included between
C                         the limits BKPT(NORD) and BKPT(NBKPT-NORD+1).
C                         The additional end knots BKPT(I),I=1,...,
C                         NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are
C                         required to compute the functions used to fit
C                         the data.  No sorting of BKPT(*) is required.
C                         Internal to DEFC( ) the extreme end knots may
C                         be reduced and increased respectively to
C                         accommodate any data values that are exterior
C                         to the given knot values.  The contents of
C                         BKPT(*) is not changed.
C
C                         NORD must be in the range 1 .LE. NORD .LE. 20.
C                         The value of NBKPT must satisfy the condition
C                         NBKPT .GE. 2*NORD.
C                         Other values are considered errors.
C
C                         (The order of the spline is one more than the
C                         degree of the piecewise polynomial defined on
C                         each interval.  This is consistent with the
C                         B-spline package convention.  For example,
C                         NORD=4 when we are using piecewise cubics.)
C
C        MDEIN
C                         An integer flag, with one of two possible
C                         values (1 or 2), that directs the subprogram
C                         action with regard to new data points provided
C                         by the user.
C
C                         =1  The first time that DEFC( ) has been
C                         entered.  There are NDATA points to process.
C
C                         =2  This is another entry to DEFC().  The sub-
C                         program DEFC( ) has been entered with MDEIN=1
C                         exactly once before for this problem.  There
C                         are NDATA new additional points to merge and
C                         process with any previous points.
C                         (When using DEFC( ) with MDEIN=2 it is import-
C                         ant that the set of knots remain fixed at the
C                         same values for all entries to DEFC( ).)
C       LW
C                         The amount of working storage actually
C                         allocated for the working array W(*).
C                         This quantity is compared with the
C                         actual amount of storage needed in DEFC( ).
C                         Insufficient storage allocated for W(*) is
C                         an error.  This feature was included in DEFC
C                         because misreading the storage formula
C                         for W(*) might very well lead to subtle
C                         and hard-to-find programming bugs.
C
C                         The length of the array W(*) must satisfy
C
C                         LW .GE. (NBKPT-NORD+3)*(NORD+1)+
C                                 (NBKPT+1)*(NORD+1)+
C                               2*MAX(NDATA,NBKPT)+NBKPT+NORD**2
C
C  Output.. All TYPE REAL variables are DOUBLE PRECISION
C      MDEOUT
C                         An output flag that indicates the status
C                         of the curve fit.
C
C                         =-1  A usage error of DEFC( ) occurred.  The
C                         offending condition is noted with the SLATEC
C                         library error processor, XERMSG( ).  In case
C                         the working array W(*) is not long enough, the
C                         minimal acceptable length is printed.
C
C                         =1  The B-spline coefficients for the fitted
C                         curve have been returned in array COEFF(*).
C
C                         =2  Not enough data has been processed to
C                         determine the B-spline coefficients.
C                         The user has one of two options.  Continue
C                         to process more data until a unique set
C                         of coefficients is obtained, or use the
C                         subprogram DFC( ) to obtain a specific
C                         set of coefficients.  The user should read
C                         the usage instructions for DFC( ) for further
C                         details if this second option is chosen.
C      COEFF(*)
C                         If the output value of MDEOUT=1, this array
C                         contains the unknowns obtained from the least
C                         squares fitting process.  These N=NBKPT-NORD
C                         parameters are the B-spline coefficients.
C                         For MDEOUT=2, not enough data was processed to
C                         uniquely determine the B-spline coefficients.
C                         In this case, and also when MDEOUT=-1, all
C                         values of COEFF(*) are set to zero.
C
C                         If the user is not satisfied with the fitted
C                         curve returned by DEFC( ), the constrained
C                         least squares curve fitting subprogram DFC( )
C                         may be required.  The work done within DEFC( )
C                         to accumulate the data can be utilized by
C                         the user, if so desired.  This involves
C                         saving the first (NBKPT-NORD+3)*(NORD+1)
C                         entries of W(*) and providing this data
C                         to DFC( ) with the "old problem" designation.
C                         The user should read the usage instructions
C                         for subprogram DFC( ) for further details.
C
C  Working Array.. All TYPE REAL variables are DOUBLE PRECISION
C      W(*)
C                         This array is typed DOUBLE PRECISION.
C                         Its length is  specified as an input parameter
C                         in LW as noted above.  The contents of W(*)
C                         must not be modified by the user between calls
C                         to DEFC( ) with values of MDEIN=1,2,2,... .
C                         The first (NBKPT-NORD+3)*(NORD+1) entries of
C                         W(*) are acceptable as direct input to DFC( )
C                         for an "old problem" only when MDEOUT=1 or 2.
C
C  Evaluating the
C  Fitted Curve..
C                         To evaluate derivative number IDER at XVAL,
C                         use the function subprogram DBVALU( ).
C
C                         F = DBVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER,
C                                      XVAL,INBV,WORKB)
C
C                         The output of this subprogram will not be
C                         defined unless an output value of MDEOUT=1
C                         was obtained from DEFC( ), XVAL is in the data
C                         interval, and IDER is nonnegative and .LT.
C                         NORD.
C
C                         The first time DBVALU( ) is called, INBV=1
C                         must be specified.  This value of INBV is the
C                         overwritten by DBVALU( ).  The array WORKB(*)
C                         must be of length at least 3*NORD, and must
C                         not be the same as the W(*) array used in the
C                         call to DEFC( ).
C
C                         DBVALU( ) expects the breakpoint array BKPT(*)
C                         to be sorted.
C
C***REFERENCES  R. J. Hanson, Constrained least squares curve fitting
C                 to discrete data using B-splines, a users guide,
C                 Report SAND78-1291, Sandia Laboratories, December
C                 1978.
C***ROUTINES CALLED  DEFCMN
C***REVISION HISTORY  (YYMMDD)
C   800801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Change Prologue comments to refer to XERMSG.  (RWC)
C   900607  Editorial changes to Prologue to make Prologues for EFC,
C           DEFC, FC, and DFC look as much the same as possible.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DEFC
C
C      SUBROUTINE           FUNCTION/REMARKS
C
C      DBSPVN( )          COMPUTE FUNCTION VALUES OF B-SPLINES.  FROM
C                         THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE.
C
C      DBNDAC( ),         BANDED LEAST SQUARES MATRIX PROCESSORS.
C      DBNDSL( )          FROM LAWSON-HANSON, SOLVING LEAST
C                         SQUARES PROBLEMS.
C
C      DSORT( )           DATA SORTING SUBROUTINE, FROM THE
C                         SANDIA MATH. LIBRARY, SAND77-1441.
C
C      XERMSG( )          ERROR HANDLING ROUTINE
C                         FOR THE SLATEC MATH. LIBRARY.
C                         SEE SAND78-1189, BY R. E. JONES.
C
C      DCOPY( ),DSCAL( )  SUBROUTINES FROM THE BLAS PACKAGE.
C
C                         WRITTEN BY R. HANSON, SANDIA NATL. LABS.,
C                         ALB., N. M., AUGUST-SEPTEMBER, 1980.
C
      DOUBLE PRECISION BKPT(*),COEFF(*),W(*),SDDATA(*),XDATA(*),YDATA(*)
      INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD
C
      EXTERNAL DEFCMN
C
      INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW
C
C***FIRST EXECUTABLE STATEMENT  DEFC
C     LWW=1               USAGE IN DEFCMN( ) OF W(*)..
C     LWW,...,LG-1        W(*,*)
C
C     LG,...,LXTEMP-1     G(*,*)
C
C     LXTEMP,...,LPTEMP-1 XTEMP(*)
C
C     LPTEMP,...,LBKPT-1  PTEMP(*)
C
C     LBKPT,...,LBF       BKPT(*) (LOCAL TO DEFCMN( ))
C
C     LBF,...,LBF+NORD**2 BF(*,*)
C
      MDG = NBKPT+1
      MDW = NBKPT-NORD+3
      LWW = 1
      LG = LWW + MDW*(NORD+1)
      LXTEMP = LG + MDG*(NORD+1)
      LPTEMP = LXTEMP + MAX(NDATA,NBKPT)
      LBKPT  = LPTEMP + MAX(NDATA,NBKPT)
      LBF = LBKPT + NBKPT
      CALL DEFCMN(NDATA,XDATA,YDATA,SDDATA,
     1         NORD,NBKPT,BKPT,
     2         MDEIN,MDEOUT,
     3         COEFF,
     4         W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT),
     5         W(LG),MDG,W(LWW),MDW,LW)
      RETURN
      END


MODULE mod_fft
IMPLICIT NONE
PRIVATE
PUBLIC :: init_fft, fft23, fft23han ! SUBROUTINE
INTEGER, PUBLIC :: indx576(1152), indx192(384)
COMPLEX (KIND = 8), PUBLIC :: omega576(0:1151), omega192(0:383), sqrt3_2
REAL     (KIND = 8), PUBLIC :: han576(1152), han192(384)
REAL     (KIND = 8) :: pi
CONTAINS
!-----------------------------------------------------------------------------------------------------------------
SUBROUTINE init_fft
IMPLICIT NONE
INTEGER :: i, k, n, m
pi = 4.0d0 * ATAN(1.0d0)
sqrt3_2 = CMPLX(0.0d0, SQRT(0.75d0), KIND = 8) ! iSQRT(3) / 2
!
indx576 = 1
DO i = 1, 1152
 DO k = 1, 7
  n = 2**(k - 1)
  m = 1152 / 2**k
  indx576(i) = indx576(i) + ( MOD(i - 1, 2 * m) / m ) * n
 END DO
 DO k = 1, 2
  n = 2**6 * 3**(k - 1)
  m = 1152 / 2**6 / 3**k
  indx576(i) = indx576(i) + ( MOD(i - 1, 3 * m) / m ) * n
 END DO
 omega576(i - 1) = EXP( CMPLX(0.0d0, 2.0d0 * pi / 1152.0d0 * REAL(i - 1, KIND = 8), KIND = 8) )
! han576(i) = SQRT(8.0d0 / 3.0d0) * 0.5d0 *( 1.0d0 - COS(2.0d0 * pi * REAL(i - 1, KIND = 8) / 1152.0d0 ) )
 han576(i) = 0.5d0 *( 1.0d0 - COS(2.0d0 * pi * REAL(i - 1, KIND = 8) / 1152.0d0 ) )
END DO
!
indx192 = 1
DO i = 1, 192
 DO k = 1, 6
  n = 2**(k - 1)
  m = 384 / 2**k
  indx192(i) = indx192(i) + ( MOD(i - 1, 2 * m) / m ) * n
 END DO
 DO k = 1, 1
  n = 2**6 * 3**(k - 1)
  m = 384 / 2**6 / 3**k
  indx192(i) = indx192(i) + ( MOD(i - 1, 3 * m) / m ) * n
 END DO
 omega192(i - 1) = EXP( CMPLX(0.0d0, 2.0d0 * pi / 384.0d0 * REAL(i - 1, KIND = 8), KIND = 8) )
! han192(i) = SQRT(8.0d0 / 3.0d0) * 0.5d0 *( 1.0d0 - COS(2.0d0 * pi * REAL(i - 1, KIND = 8) / 384.0d0 ) )
 han192(i) = 0.5d0 *( 1.0d0 - COS(2.0d0 * pi * REAL(i - 1, KIND = 8) / 384.0d0 ) )
END DO
END SUBROUTINE init_fft
!-----------------------------------------------------------------------------------------------------------------
SUBROUTINE fft23(np2, np3, indx, omega, fft)
INTEGER           , INTENT(IN    ) :: np2, np3, indx(:)
COMPLEX (KIND = 8), INTENT(IN    ) :: omega(0:)
COMPLEX (KIND = 8), INTENT(IN OUT) :: fft(:)
COMPLEX (KIND = 8) :: c1, c2, c3, c4, tmp1, tmp2, tmp3
INTEGER :: i, j, nn, iphase1, iphase2, m1, m2, m3, k3, kn3, k2, kn2
nn = 2**np2 * 3**np3
fft = fft(indx) / REAL(nn, KIND = 8) ! reorder and normalize
! 3**np3
DO k3 = 1, np3 ! 3^n (n=2)
 kn3 = 3**(k3 - 1)
 DO i = 1, nn, 3 * kn3
  DO j = 1, kn3
   iphase1 = 2**np2 * 3**(np3 - k3) * (j - 1)
   iphase2 = 2 * iphase1
   c1 = omega( MOD(iphase1, nn) )
   c2 = omega( MOD(iphase2, nn) )
   m1 = i + j - 1
   m2 = m1 + kn3
   m3 = m2 + kn3
   tmp1 =      fft(m1)
   tmp2 = c1 * fft(m2)
   tmp3 = c2 * fft(m3)
   fft(m1) = tmp1 + tmp2 + tmp3
   c3 = tmp1 - 0.5d0 * ( tmp2 + tmp3 )
   c4 =      sqrt3_2 * ( tmp2 - tmp3 ) ! sqrt3_2 = i sqrt(3) / 2
   fft(m2) = c3 + c4
   fft(m3) = c3 - c4
  END DO
 END DO
END DO
! 2**np2
DO k2 = 1, np2
 kn2 = 2**(k2 - 1) * 3**np3
 DO i = 1, nn, 2 * kn2
  DO j = 1, kn2
   iphase1 = 2**(np2 - k2) * (j - 1)
   c1 = omega( MOD(iphase1, nn) )
   m1 = i + j - 1
   m2 = m1 + kn2
   tmp2 = c1 * fft(m2)
   fft(m2) = fft(m1) - tmp2
   fft(m1) = fft(m1) + tmp2
  END DO
 END DO
END DO
RETURN
END SUBROUTINE fft23
!-----------------------------------------------------------------------------------------------------------------
SUBROUTINE fft23han(np2, np3, indx, omega, fft, han)
INTEGER           , INTENT(IN    ) :: np2, np3, indx(:)
COMPLEX (KIND = 8), INTENT(IN    ) :: omega(0:)
COMPLEX (KIND = 8), INTENT(IN OUT) :: fft(:)
REAL     (KIND = 8), INTENT(IN    ) :: han(:)
fft = fft * han
CALL fft23(np2, np3, indx, omega, fft)
RETURN
END SUBROUTINE fft23han
!-----------------------------------------------------------------------------------------------------------------
END MODULE mod_fft
!==================================================================================================================
MODULE mod_psycho
USE mod_mpg
USE mod_fft
IMPLICIT NONE
PRIVATE
PUBLIC :: psycho, calc_mask  ! subroutine
REAL (KIND = 8) :: pi, pi2
REAL (KIND = 8) :: ath_l(576) , ath_s(192, 3)
REAL (KIND = 8) :: sf_l(576, 576), sf_s(192, 192)
REAL (KIND = 8) :: afft_l(576, 2, 2), afft_s(192, 3, 2, 2)
REAL (KIND = 8) :: phi_l(576, 2, 2), phi_s(192, 3, 2, 2)
REAL (KIND = 8) :: freq_l(576), freq_s(192), bark_l(576), bark_s(192), bw_l(576), bw_s(192)
REAL (KIND = 8) :: weight_l(576), weight_s(192)
INTEGER        :: ibark_l(576), ibark_s(192), ifb_l(25, 0:2), ifb_s(25, 0:2)
!
CONTAINS
!----------------------------------------------------------------
SUBROUTINE init_absolute_threshold(isample_rate)
IMPLICIT NONE
INTEGER, INTENT(IN ) :: isample_rate
REAL(KIND = 8):: freq, temp !, ath(576)
INTEGER :: i, k
pi  = 4.0d0 * ATAN(1.0d0)
pi2 = 2.0d0 * pi
DO i = 1, 576
 freq = REAL(isample_rate, KIND = 8) / 2.0d0 / 1000.0d0 * (REAL(i, KIND = 8) - 0.0d0) / 576.0d0
!  temp =  3.64d0  * freq ** (-0.8d0) &
!       -  6.50d0  * EXP(-0.6d0 * (freq -  3.3d0)**2.0d0) &
!       +  0.001d0 * freq ** 4.0d0 &
!       + ath_min
 temp = 3.64d0 * freq ** (-0.8d0) &                     ! alternative ATH function
      - 6.50d0 * EXP(-0.6d0 * (freq - 3.3d0)**2.0d0) &  ! reference: LAME ath-type 3
      + 5.1d0
!
 IF      (freq >  5.0d0 .AND. freq <=  5.5d0) THEN
  temp =  5.1d0 + 4.0d0 * (freq -  5.0d0)
 ELSE IF (freq >  5.5d0 .AND. freq <=  8.0d0) THEN
  temp =  7.1d0 + 2.76d0 * (freq -  5.5d0)
 ELSE IF (freq >  8.0d0 .AND. freq <= 10.0d0) THEN
  temp = 14.0d0 + 1.00d0 * (freq -  8.0d0)
 ELSE IF (freq > 10.0d0 .AND. freq <= 11.5d0) THEN
  temp = 16.0d0 + 0.33d0 * (freq - 10.0d0)
 ELSE IF (freq > 11.5d0 .AND. freq <= 12.0d0) THEN
  temp = 16.5d0 + 2.0d0 * (freq - 11.5d0)
 ELSE IF (freq > 12.0d0) THEN
  temp = 0.001d0 * freq ** 3.81d0 + 4.60d0  ! 12.93
!
!  temp = 0.001d0 * freq ** 3.80d0 + 4.92d0  ! 12.61
!  temp = 0.001d0 * freq ** 3.81d0 + 4.60d0  ! 12.93
!  temp = 0.001d0 * freq ** 3.82d0 + 4.27d0  ! 13.26
!  temp = 0.001d0 * freq ** 3.83d0 + 3.94d0  ! 13.59
!  temp = 0.001d0 * freq ** 3.84d0 + 3.61d0  ! 13.93
!  temp = 0.001d0 * freq ** 3.85d0 + 3.27d0  ! 14.28
!  temp = 0.001d0 * freq ** 4.00d0 - 2.86d0  ! 20.70
 END IF
 temp = MIN(temp + ath_min, ath_max)
 ath_l(i) = 10.0d0**(temp / 20.0d0)
END DO
!
DO i = 1, 192
 k = 3 * (i - 1) + 1
 ath_s(i, :) = MINVAL( ath_l(k:k + 2) )
END DO
RETURN
END SUBROUTINE init_absolute_threshold
!------------------------------------------------------------------------------------------------
FUNCTION switch_q(wx) RESULT(ires) ! attack detection (UZURA original)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN) :: wx(:, :)
INTEGER :: ires
REAL (KIND = 8), SAVE :: sum0a, sum1a, sum0b, sum1b
sum0a = sum1a
sum1a = SUM( wx(1:36, :) )
sum0b = sum1b
sum1b = SUM( wx(37: , :) )
IF  ( sum1a > switch * sum0a .OR. sum1b > switch * sum0b ) THEN
 ires = mblock_type_param
 IF (q_sm .AND. sum1a < xsm * sum0a .AND. sum0a < xsm * sum1a ) ires = 21 ! mixed
ELSE
 ires = 0
END IF
IF (mblock_type_param == 0) ires = 0 ! force long-only mode
!debug info
if ( sum1a >= switch * sum0a ) nn1 = nn1 + 1
if ( sum1b >= switch * sum0b ) nn2 = nn2 + 1
RETURN
END FUNCTION switch_q
!--------------------------------------------------------------------------------------------------------------------
SUBROUTINE attack(wx, mblock_type) !..... ! ISO Figure C.7 (p.95) Window Switching State Diagram
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: wx(:, :, :)
INTEGER        , INTENT(OUT) :: mblock_type(:, :)
INTEGER :: i, iattack
INTEGER, SAVE :: mblock_prev = 0
DO i = 1, 2
 iattack = switch_q(wx(:, i, :))
 SELECT CASE (iattack)
  CASE (0) ! no-attack
    SELECT CASE (mblock_prev)
      CASE ( 0, 30, 31) ! long
        mblock_type(i, :) =  0
      CASE (10)
        mblock_type(i, :) = 20
      CASE (11)
        mblock_type(i, :) = 21
      CASE (20) ! short
        mblock_type(i, :) = 30
      CASE (21) ! mixed
        mblock_type(i, :) = 31
      CASE DEFAULT
        WRITE(*, *) 'error: psycho : unexpected block type: case 0-x', i, mblock_prev, mblock_type(i, 1)
        STOP
      END SELECT
  CASE (20) ! attack-short
    SELECT CASE (mblock_prev)
      CASE ( 0, 30, 31)
        mblock_type(i, :) = 10
      CASE (10)
        mblock_type(i, :) = 20
      CASE (11)
        mblock_type(i, :) = 21
      CASE (20)
        mblock_type(i, :) = 20
      CASE (21)
        mblock_type(i, :) = 21
      CASE DEFAULT
        WRITE(*, *) 'error: psycho : unexpected block type: case 20-x', i, mblock_prev, mblock_type(i, 1)
        STOP
      END SELECT
  CASE (21) ! attack-mixed
    SELECT CASE (mblock_prev)
      CASE ( 0, 30, 31)
        mblock_type(i, :) = 11
      CASE (10)
        mblock_type(i, :) = 20
      CASE (11)
        mblock_type(i, :) = 21
      CASE (20)
        mblock_type(i, :) = 20
      CASE (21)
        mblock_type(i, :) = 21
      CASE DEFAULT
        WRITE(*, *) 'error: psycho : unexpected block type: case 21-x', i, mblock_prev, mblock_type(i, 1)
        STOP
      END SELECT
  CASE DEFAULT
    WRITE(*, *) 'error: psycho : unexpected block type'
    STOP
 END SELECT
 !mblock_type = 20 ! for debug
 mblock_prev = mblock_type(i, 1)
!....... debug info ...............................................
 select case ( mblock_type(i, 1) )
  case ( 0)
   long = long + 1
  case (20)
   nshort = nshort + 1
  case (21)
   mix = mix + 1
  case (10, 11)
   m1 = m1 + 1
  case (30, 31)
   m3 = m3 + 1
 end select
!
END DO
RETURN
END SUBROUTINE attack
!-----------------------------------------------------------------------------------------------------------------------
! not working correctly ; MDCT based version is better
SUBROUTINE mid_side(mpg, wx, mblock_type) ! ISO  C.2.4.3.4.9.2,  G.2 MS_Stereo and intensity stereo coding Layer III
IMPLICIT NONE
REAL (KIND = 8)       , INTENT(IN    ) :: wx(:, :, :)
TYPE (mpeg_parameters), INTENT(IN OUT) :: mpg
INTEGER        , INTENT(IN) :: mblock_type(:, :)
INTEGER         :: igranule, nchannel, n0, n1
REAL (KIND = 8) :: tmp1, tmp2
INTEGER, SAVE :: mode_old = 0, mode_ext_old = 0
LOGICAL         :: qms
nchannel = SIZE(wx, 3)
qms = qms_stereo
SELECT CASE (mpg%isample_rate) ! threshold ~ 7kHz (empirical value)
 CASE (0) ! 44.1kHz
  n0 = 183
 CASE (1) ! 48.0kHz
  n0 = 168
 CASE (2) ! 32.0kHz
  n0 = 252
 CASE DEFAULT
  STOP ' sample_rate error : SUBROUTINE mid_side '
END SELECT
n1 = n0 + 1
tmp1 = 0.0d0
tmp2 = 0.0d0
DO igranule = 1, 2
! pop musics often have different L-R behavior in low and high frequency
 tmp1 = tmp1 + SUM( ABS( wx(1:n0, igranule, 1) - wx(1:n0, igranule, 2) ) )
 tmp2 = tmp2 + SUM(    ( wx(1:n0, igranule, 1) + wx(1:n0, igranule, 2) ) )
END DO
IF ( tmp1 > xms * tmp2 ) THEN
 qms = .FALSE.
 ns1 = ns1 + 1
 ns  = ns  + 1
END IF
n1 = n0 + 1
tmp1 = 0.0d0
tmp2 = 0.0d0
DO igranule = 1, 2
! pop musics often have different L-R behavior in low and high frequency
 tmp1 = tmp1 + SUM( ABS( wx(n1:, igranule, 1) - wx(n1:, igranule, 2) ) )
 tmp2 = tmp2 + SUM(    ( wx(n1:, igranule, 1) + wx(n1:, igranule, 2) ) )
END DO
IF ( ABS(tmp1) > xms * ABS(tmp2) ) THEN
 qms = .FALSE.
 ns1 = ns1 + 1
 ns  = ns  + 1
END IF
!
IF (mblock_type(1, 1) /= 0 .AND. mblock_type(1, 1) /= 20 .AND. mblock_type(1, 1) /= 21) THEN
 mpg%mode = 0 !mode_old
 mpg%mode_extension = 0 ! mode_ext_old
ELSE
 IF (qms) THEN
  mpg%mode            =  1 ! joint stereo
  mpg%mode_extension  =  2 ! intensity_stereo off / ms_stereo on
  ms = ms + 1
 ELSE
  mpg%mode            =  0 ! normal stereo
  mpg%mode_extension  =  0 ! intensity_stereo off / ms_stereo off
 END IF
END IF
mode_old     = mpg%mode
mode_ext_old = mpg%mode_extension
RETURN
END SUBROUTINE mid_side
!------------------------------------------------------------------------------------------------
SUBROUTINE fft_long(nchannel, pcm, afft_l, phi_l)
IMPLICIT NONE
INTEGER       , INTENT(IN ) :: nchannel
REAL (KIND = 8), INTENT(IN ) :: pcm(:, :)
REAL (KIND = 8), INTENT(OUT) :: afft_l(:, :, :), phi_l(:, :, :)
COMPLEX (KIND = 8) :: fft576(1152, 2, 2)
INTEGER :: ichannel, igranule, m1,m2
DO igranule = 1, 2
 DO ichannel = 1, nchannel
  m1 = 1 + 480 * (igranule - 1)
  m2 = m1 + 1152 - 1
  fft576(:, igranule, ichannel) = CMPLX(PCM(m1:m2, ichannel), 0.0d0, KIND = 8) ! put 1152 real data -> get 576 complex FFT
!  CALL fft23han(7, 2, indx576, omega576, fft576(:, igranule, ichannel), han576 ) ! 2^7 * 3^2 = 1152
  CALL fft23(7, 2, indx576, omega576, fft576(:, igranule, ichannel) )
  afft_l (:, igranule, ichannel) = ABS(fft576(1:576, igranule, ichannel))
  afft_l (:, igranule, ichannel) = afft_l (:, igranule, ichannel)
  phi_l(:, igranule, ichannel) = ATAN2(AIMAG(fft576(1:576, igranule, ichannel)), REAL(fft576(1:576, igranule, ichannel)))
 END DO
END DO
phi_l = phi_l + pi ! ATAN -pi~pi -> 0~2pi
RETURN
END SUBROUTINE fft_long
!------------------------------------------------------------------------------------------------
SUBROUTINE fft_short(nchannel, pcm, afft_s, phi_s)
IMPLICIT NONE
INTEGER       , INTENT(IN ) :: nchannel
REAL (KIND = 8), INTENT(IN ) :: pcm(:, :)
REAL (KIND = 8), INTENT(OUT) :: afft_s(:, :, :, :), phi_s(:, :, :, :)
COMPLEX (KIND = 8) :: fft192(384, 3, 2, 2)
INTEGER :: ichannel, igranule, iwin, m1, m2
DO igranule = 1, 2
 DO ichannel = 1, nchannel
  DO iwin = 1, 3
   m1 = 1 + 480 * (igranule - 1) + 384 * (iwin - 1)
   m2 = m1 + 384 - 1
   fft192(:, iwin, igranule, ichannel) = CMPLX(PCM(m1:m2, ichannel), 0.0d0, KIND = 8) ! put 384 real data -> get 192 complex FFT
 !  CALL fft23han(7, 1, indx192, omega192, fft192(:, iwin, igranule, ichannel), han192 ) ! 2^7 * 3^1 = 384
   CALL fft23(7, 1, indx192, omega192, fft192(:, iwin, igranule, ichannel) )
   afft_s (:, iwin, igranule, ichannel) = ABS(fft192(1:192, iwin, igranule, ichannel))
   afft_s (:, iwin, igranule, ichannel) = afft_s (:, iwin, igranule, ichannel)
   phi_s(:, iwin, igranule, ichannel) = ATAN2(AIMAG(fft192(1:192, iwin, igranule, ichannel)), REAL(fft192(1:192, iwin, igranule, ichannel)))
  END DO
 END DO
END DO
phi_s = phi_s + pi ! ATAN2 -pi~pi -> 0~2pi
RETURN
END SUBROUTINE fft_short
!------------------------------------------------------------------------------------------------
SUBROUTINE calc_wx(nchannel, wx)
IMPLICIT NONE
INTEGER      , INTENT(IN ) :: nchannel
REAL(KIND = 8), INTENT(OUT) :: wx(:, :, :)
INTEGER :: igranule, ichannel
DO igranule = 1, 2
 DO ichannel = 1, nchannel
  wx(:, igranule, ichannel) = ( afft_l(:, igranule, ichannel) * weight_l )**2.0d0
 END DO
END DO
RETURN
END SUBROUTINE calc_wx
!------------------------------------------------------------------------------------------------
SUBROUTINE psycho(pcm, mpg, mblock_type)
IMPLICIT NONE
TYPE (mpeg_parameters), INTENT(IN OUT) :: mpg
INTEGER               , INTENT(   OUT) :: mblock_type(:, :)
REAL (KIND = 8)       , INTENT(IN    ) :: pcm(:, :)
LOGICAL, SAVE :: qfirst = .true.
INTEGER        :: igranule, ichannel, nchannel
real (kind = 8) :: wx(576, 2, 2), pm, pm0(2, 2)
!..... initialization .........................................................................................
IF (qfirst) THEN
 qfirst = .false.
 !!!- to avoid VBR bug of portable MP3 player DIAMOND MULTIMEDIA RIO500. first frame bitrate must be less than average bitrate
 IF (q_vbr .and. q_rio500) mpg%ibit_rate = 8 ! force first frame 112kbps for RIO500 (firmware 1.15)
 CALL init_absolute_threshold( mpeg_sample_rates(mpg%isample_rate) )
 CALL init_mask( mpeg_sample_rates(mpg%isample_rate) )
 CALL init_fft()
END IF
!..... FFT 576/192 ............................................................................................
nchannel = SIZE(mblock_type, 2)
CALL fft_long (nchannel, pcm, afft_l, phi_l)
CALL fft_short(nchannel, pcm, afft_s, phi_s)
!..... weighted intensity .....................................................................................
CALL calc_wx(nchannel, wx)
!..... attack detection .......................................................................................
CALL attack(wx, mblock_type)
!..... MS/NS selection ........................................................................................
!CALL mid_side(mpg, wx, mblock_type) ! not working correctly : MDCT based model works better
!..... VBR  ...................................................................................................
IF (q_vbr) THEN ! simple implimentation
 DO igranule = 1, 2
  DO ichannel = 1, nchannel
   pm0(igranule, ichannel) = SUM(wx(:, igranule, ichannel) * bark_l) !Psychoacoustic Moment (UZURA original)
  END DO
 END DO
 pm = SUM(pm0) / ( SUM(wx) + 1.0d-9 )
 IF (pm < 0.1d0) THEN
   mpg%ibit_rate =  1
 ELSE IF (pm             < 1.0d0) THEN
   mpg%ibit_rate =  9
 ELSE IF (pm * pm_factor < 2.5d0) THEN
   mpg%ibit_rate = 10
 ELSE IF (pm * pm_factor < 3.5d0) THEN
   mpg%ibit_rate = 11
 ELSE IF (pm * pm_factor < 5.0d0) THEN
   mpg%ibit_rate = 12
 ELSE IF (pm * pm_factor < 7.0d0) THEN
   mpg%ibit_rate = 13
 ELSE
   mpg%ibit_rate = 14
 END IF
END IF
nbits(mpg%ibit_rate) = nbits(mpg%ibit_rate) + 1
RETURN
END SUBROUTINE psycho
!------------------------------------------------------------------------------------------------
SUBROUTINE init_mask(nsample_rate)
IMPLICIT NONE
INTEGER, INTENT(IN) :: nsample_rate
INTEGER :: i, j
REAL (KIND  = 8) :: f0, f1
DO i = 1, 576
 freq_l(i) = REAL(nsample_rate, KIND = 8) / 2.0d0 * (REAL(i, KIND = 8) - 0.5d0) / 576.0d0 ! kHz
 bark_l(i) = bark(freq_l(i) / 1000.0d0)
 ibark_l(i) = INT(bark_l(i) + 0.1d0) + 1
 f0 = REAL(nsample_rate, KIND = 8) / 2000.0d0 * REAL(i - 1, KIND = 8) / 576.0d0
 f1 = REAL(nsample_rate, KIND = 8) / 2000.0d0 * REAL(i    , KIND = 8) / 576.0d0
 bw_l(i) = bark(f1) - bark(f0)
 weight_l(i) = ( bark(f1) - bark(f0) ) / (f1 - f0)
END DO
DO i = 1, 192
 freq_s(i) = REAL(nsample_rate, KIND = 8) / 2.0d0 * (REAL(i, KIND = 8) - 0.5d0) / 192.0d0 ! kHz
 bark_s(i) = bark(freq_s(i) / 1000.0d0)
 ibark_s(i) = INT(bark_s(i)) + 1
 f0 = REAL(nsample_rate, KIND = 8) / 2000.0d0 * REAL(i - 1, KIND = 8) / 192.0d0
 f1 = REAL(nsample_rate, KIND = 8) / 2000.0d0 * REAL(i    , KIND = 8) / 192.0d0
 bw_s(i) = bark(f1) - bark(f0)
 weight_s(i) = ( bark(f1) - bark(f0) ) / (f1 - f0)
END DO
!
ifb_l(1, 1) = 1
DO i = 1, 25
 DO j = 1, 576
  IF (ibark_l(j) == i - 1) ifb_l(i, 1) = j + 1
  IF (ibark_l(j) == i    ) ifb_l(i, 2) = j
 END DO
 ifb_l(i, 0) = ifb_l(i, 2) - ifb_l(i, 1) + 1
END DO
ifb_s(1, 1) = 1
DO i = 1, 25
 DO j = 1, 192
  IF (ibark_s(j) == i - 1) ifb_s(i, 1) = j + 1
  IF (ibark_s(j) == i    ) ifb_s(i, 2) = j
 END DO
 ifb_s(i, 0) = ifb_s(i, 2) - ifb_s(i, 1) + 1
END DO
!
DO i = 1, 576
 DO j = 1, 576
  sf_l(i, j) = 10.0d0 ** ( spreading_function( bark_l(i) - bark_l(j) ) / 20.0d0 )
 END DO
END DO
DO i = 1, 192
 DO j = 1, 192
  sf_s(i, j) = 10.0d0 ** ( spreading_function( bark_s(i) - bark_s(j) ) / 20.0d0 )
 END DO
END DO
RETURN
END SUBROUTINE init_mask
!------------------------------------------------------------------------------------------------
SUBROUTINE calc_mask(igranule, ichannel, mblock_type, xmask, xnoise)
IMPLICIT NONE
INTEGER       , INTENT(IN    ) :: igranule, ichannel, mblock_type
REAL (KIND = 8), INTENT(   OUT) :: xmask(:, :), xnoise(:, :)
REAL (KIND = 8) :: x0_l(576), x0_s(192, 3), y0_l(576), y0_s(192, 3)
REAL (KIND = 8) :: d2phi_l(576), tone_l(576), fk_l(576), fl_l(576), tn_l(576)
REAL (KIND = 8) :: d2phi_s(192), tone_s(192), fk_s(192), fl_s(192), tn_s(192)
REAL (KIND = 8) :: yn(25)
REAL (KIND = 8), SAVE :: x1_l(576) = 0.0d0, x1_s(192, 3) = 0.0d0
REAL (KIND = 8), SAVE :: phi1_l(576, 2) = 0.0d0, phi2_l(576, 2) = 0.0d0
REAL (KIND = 8), SAVE :: phi1_s(192, 2) = 0.0d0, phi2_s(192, 2) = 0.0d0
REAL (KIND = 8), SAVE :: p0_l(576, 2) = 0.0d0, p1_l(576, 2) = 0.0d0, p2_l(576, 2) = 0.0d0
REAL (KIND = 8), SAVE :: p0_s(192, 2) = 0.0d0, p1_s(192, 2) = 0.0d0, p2_s(192, 2) = 0.0d0
REAL (KIND = 8), SAVE :: p3_s(192, 2) = 0.0d0, p4_s(192, 2) = 0.0d0, p5_s(192, 2) = 0.0d0
INTEGER :: icritical_band, iwin
!---------------------------------------------------------------------------------------------
! masking / allowed noise : reference Bosse Lincoln "An Experimental High Fidelity Perceptual Audio Coder Project in MUS420 Win 97"
!---------------------------------------------------------------------------------------------
d2phi_l = phi_l(:, igranule, ichannel) + phi2_l(:, ichannel) - 2.0d0 * phi1_l(:, ichannel)
p0_l(:, ichannel) = MOD( ABS(d2phi_l), pi2 ) / pi2
tone_l = 1.0d0 - MAX(p0_l(:, ichannel), p1_l(:, ichannel), p2_l(:, ichannel) )
! mask for long block
fk_l =  0.3d0 * tone_l +  0.5d0 * (1 - tone_l)
fl_l = 34.0d0 * tone_l + 20.0d0 * (1 - tone_l)
tn_l = 10.0d0**( - ( fk_l * bark_l + fl_l + offset ) / 20.0d0 )
x0_l = MATMUL(sf_l, afft_l(:, igranule, ichannel) * tn_l * weight_l) + ath_l
x1_l = tempo * x1_l + (1.0d0 - tempo) * x0_l ! temporal masking
x0_l = MAX(x0_l, x1_l)
! allowed noise for long block : average mask over a critical band
DO icritical_band = 1, 25
 yn(icritical_band) = SUM( x0_l(ifb_l(icritical_band, 1):ifb_l(icritical_band, 2)) ) / REAL(ifb_l(icritical_band, 0), KIND = 8)
END DO
y0_l = MAX( ath_l, yn(ibark_l) )
! save old data
p1_l(:, ichannel) = p0_l(:, ichannel)
p2_l(:, ichannel) = p1_l(:, ichannel)
phi1_l(:, ichannel) = phi_l(:, igranule, ichannel)
phi2_l(:, ichannel) = phi1_l(:, ichannel)
!
DO iwin = 1, 3
 d2phi_s = phi_s(:, iwin, igranule, ichannel) + phi2_s(:, ichannel) - 2.0d0 * phi1_s(:, ichannel)
 p0_s(:, ichannel) = MOD( ABS(d2phi_s), pi2 ) / pi2
 tone_s = 1.0d0 - MAX( p0_s(:, ichannel), p1_s(:, ichannel), p2_s(:, ichannel), &
                       p3_s(:, ichannel), p4_s(:, ichannel), p5_s(:, ichannel)  )
! mask for short block
 fk_s =  0.3d0 * tone_s +  0.5d0 * (1 - tone_s)
 fl_s = 34.0d0 * tone_s + 20.0d0 * (1 - tone_s)
 tn_s = 10.0d0**( - ( fk_s * bark_s + fl_s + offset ) / 20.0d0 )
 x0_s(:, iwin) = MATMUL(sf_s, afft_s(:, iwin, igranule, ichannel) * tn_s * weight_s) + ath_s(:, iwin)
! save old data
 p1_s(:, ichannel) = p0_s(:, ichannel)
 p2_s(:, ichannel) = p1_s(:, ichannel)
 p3_s(:, ichannel) = p2_s(:, ichannel)
 p4_s(:, ichannel) = p3_s(:, ichannel)
 p5_s(:, ichannel) = p4_s(:, ichannel)
 phi1_s(:, ichannel) = phi_s(:, iwin, igranule, ichannel)
 phi2_s(:, ichannel) = phi1_s(:, ichannel)
END DO
x1_s(:, 1) = tempo * x1_s(:, 3) + (1.0d0 - tempo) * x0_s(:, 1) ! temporal masking
x1_s(:, 2) = tempo * x1_s(:, 1) + (1.0d0 - tempo) * x0_s(:, 2) !
x1_s(:, 3) = tempo * x1_s(:, 2) + (1.0d0 - tempo) * x0_s(:, 3) !
x0_s  = MAX(x0_s, x1_s)
! allowed noise for short block  : average mask over a critical band
DO iwin = 1, 3
 DO icritical_band = 1, 25
  yn(icritical_band) = SUM( x0_s(ifb_s(icritical_band, 1):ifb_s(icritical_band, 2), iwin) ) / REAL(ifb_s(icritical_band, 0), KIND = 8)
 END DO
 y0_s(:, iwin) = MAX( ath_s(:, iwin), yn(ibark_s(:)) )
END DO
! order to r_mdct style
SELECT CASE (mblock_type)
 CASE (0, 10, 11, 30, 31)
  CALL deorder_l(x0_l, xmask )
  CALL deorder_l(y0_l, xnoise)
 CASE (20)
  CALL deorder_s(x0_s, xmask )
  CALL deorder_s(y0_s, xnoise)
 CASE (21)
  CALL deorder_m(x0_l, x0_s, xmask )
  CALL deorder_m(y0_l, y0_s , xnoise)
 CASE DEFAULT
  STOP 'SUBROUTINE: calc_noise'
END SELECT
RETURN
END SUBROUTINE calc_mask
!------------------------------------------------------------------------------------------------
SUBROUTINE deorder_l(zl, xth)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: zl(:)
REAL (KIND = 8), INTENT(OUT) :: xth(:, :)
INTEGER :: i, iband
DO iband = 1, 32
 DO i = 1, 18
  xth(iband, i) = zl(18 * (iband - 1) + i)
 END DO
END DO
RETURN
END SUBROUTINE deorder_l
!------------------------------------------------------------------------------------------------
SUBROUTINE deorder_s(zs, xth)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: zs(:, :)
REAL (KIND = 8), INTENT(OUT) :: xth(:, :)
INTEGER :: i, iwin, iband
DO iband = 1, 32
 DO iwin = 1, 3
  DO i = 1, 6
   xth(iband, 6 * (iwin - 1) + i) = zs(6 * (iband - 1) + i, iwin)
  END DO
 END DO
END DO
RETURN
END SUBROUTINE deorder_s
!------------------------------------------------------------------------------------------------
SUBROUTINE deorder_m(zl, zs, xth)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: zl(:), zs(:, :)
REAL (KIND = 8), INTENT(OUT) :: xth(:, :)
INTEGER :: i, iwin, iband
DO iband = 1, 2
 DO i = 1, 18
  xth(iband, i) = zl( 18 * (iband - 1) + i)
 END DO
END DO
DO iband = 3, 32
 DO iwin = 1, 3
  DO i = 1, 6
   xth(iband, 6 * (iwin - 1) + i) = zs(6 * (iband - 1) + i, iwin)
  END DO
 END DO
END DO
RETURN
END SUBROUTINE deorder_m
!------------------------------------------------------------------------------------------------
FUNCTION bark(f) RESULT(res)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN) :: f
REAL (KIND = 8) :: res
res = 13.0d0 * ATAN(0.76d0 * f) + 3.5d0 * ATAN( (f / 7.5d0)**2.0d0 )
RETURN
END FUNCTION bark
!------------------------------------------------------------------------------------------------
FUNCTION spreading_function(z) RESULT(res)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN) :: z
REAL (KIND = 8) :: res
res = 15.81d0 + 7.5d0 * (z + 0.474d0) - 17.5d0 * SQRT(1.0d0 + (z + 0.474d0)**2.0d0)
RETURN
END FUNCTION spreading_function
!------------------------------------------------------------------------------------------------
FUNCTION spreading_function0(z) RESULT(res)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN) :: z
REAL (KIND = 8) :: res
IF (z < 0.0d0) THEN
 res =  25.0d0 * z
ELSE
 res = -10.0d0 * z
END IF
RETURN
END FUNCTION spreading_function0
!------------------------------------------------------------------------------------------------
FUNCTION spreading_function2(z, y) RESULT(res)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN) :: z, y
REAL (KIND = 8) :: res
res = (15.81d0 - y) + 7.5d0 * (z + 0.474d0) - (17.5d0 - y) * SQRT(1.0d0 + (z + 0.474d0)**2.0d0)
RETURN
END FUNCTION spreading_function2
!------------------------------------------------------------------------------------------------
END MODULE mod_psycho


      PROGRAM xgolden
C     driver for routine golden
      REAL EQL,TOL
      PARAMETER(TOL=1.0E-6,EQL=1.E-3)
      INTEGER i,iflag,j,nmin
      REAL amin(20),ax,bx,cx,fa,fb,fc,g,xmin
      REAL bessj0,bessj1,golden
      EXTERNAL bessj0
      nmin=0
      write(*,'(/1x,a)') 'Minima of the function BESSJ0'
      write(*,'(/1x,t6,a,t19,a,t27,a,t40,a/)') 'Min. #','X',
     *     'BESSJ0(X)','BESSJ1(X)'
      do 12 i=1,100
        ax=i
        bx=i+1.0
        call mnbrak(ax,bx,cx,fa,fb,fc,bessj0)
        g=golden(ax,bx,cx,bessj0,TOL,xmin)
        if (nmin.eq.0) then
          amin(1)=xmin
          nmin=1
          write(*,'(1x,5x,i2,3x,3f12.6)') nmin,xmin,
     *         bessj0(xmin),bessj1(xmin)
        else
          iflag=0
          do 11 j=1,nmin
            if (abs(xmin-amin(j)).le.EQL*xmin)
     *           iflag=1
11        continue
          if (iflag.eq.0) then
            nmin=nmin+1
            amin(nmin)=xmin
            write(*,'(1x,5x,i2,3x,3f12.6)') nmin,
     *           xmin,bessj0(xmin),bessj1(xmin)
          endif
        endif
12    continue
      END

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


program realcomp
  ! This program tests and compares the performance
  ! of single and double precision real problems

  use flips
  use rand

  implicit none

  ! types
  type(flips_c) :: gs
  type(flips_z) :: gd

  ! data matrices
  complex(sp), dimension(:,:), allocatable :: amat_s, smat_s, mmat_s
  complex(dp), dimension(:,:), allocatable :: amat_d, smat_d, mmat_d

  ! Errors
  complex(sp) :: meanerr_d,meanerr_s
  real(dp) :: maxerr_d,maxerr_s

  ! Residuals
  real(sp) :: res_s
  real(dp) :: res_d

  ! Clocks/times
  real(dp) :: cts,cte,ctime1,ctime2
  real(sp) :: wts,wte,wtime1,wtime2

  ! Aux variables
  integer :: ns,n,bs
  real(sp), dimension(:,:), allocatable :: sauxmat, sauxmat2
  real(dp), dimension(:,:), allocatable :: dauxmat, dauxmat2

  ! Set random seed
  call set_rand_seed()

  ! Ask size
  write(*,*) 'Give matrix size:'
  read(*,*) ns

  bs = 50000/ns

  ! allocate things
  allocate(amat_s(ns,ns),amat_d(ns,ns),smat_s(ns,1),smat_d(ns,1),&
       mmat_s(ns,1),mmat_d(ns,1),sauxmat(ns,ns),sauxmat2(ns,1),&
       dauxmat(ns,ns),dauxmat2(ns,1))

  ! Single pprecision

  ! Create data (theory matrix random, soluton 1's)
  call random_number(sauxmat)
  amat_s = sauxmat
  call random_number(sauxmat)
  amat_s = amat_s + (0.0,1.0)*sauxmat
  smat_s = (1.0,1.0)
  mmat_s = matmul(amat_s,smat_s)

  ! init flips
  call flips_init(gs,ns,1,buffersize=bs)

  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gs,1,amat_s(n,:),mmat_s(n,:))
  end do
  call flips_solve(gs)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gs,full=.TRUE.)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  ! Errors
  maxerr_s = maxval(abs(smat_s(:,1) - gs%solmat))
  meanerr_s = sum(smat_s(:,1) - gs%solmat)/ns

  ! Print results
  write(*,*) '---------------------------------------'
  write(*,*) 'Single precision complex, size:',ns
  write(*,*) '---------------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_s
  write(*,*) '     Max. abs. error:',maxerr_s
  write(*,*) '            Residual:',gs%residual
  !  write(*,*) gs%cmat
  write(*,*) '---------------------------------------\n'

  ! Double precision

  ! Create data (theory matrix random, soluton 1's)
  call random_number(dauxmat)
  amat_d = dauxmat
  call random_number(dauxmat)
  amat_d = amat_d + (0.0D0,1.0D0)*dauxmat
  smat_d = (1.0D0,1.0D0)
  mmat_d = matmul(amat_d,smat_d)

  ! init flips
  call flips_init(gd,ns,1,buffersize=bs)

  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gd,1,amat_d(n,:),mmat_d(n,:))
  end do
  call flips_solve(gd)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gd,full=.TRUE.)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  ! Errors
  maxerr_d = maxval(abs(smat_d(:,1) - gd%solmat))
  meanerr_d = sum(smat_d(:,1) - gd%solmat)/ns

  ! Print results
  write(*,*) '---------------------------------------'
  write(*,*) 'Double precision complex, size:',ns
  write(*,*) '---------------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_d
  write(*,*) '     Max. abs. error:',maxerr_d
  write(*,*) '            Residual:',gd%residual
  ! write(*,*) gd%cmat
  write(*,*) '---------------------------------------\n'

end program realcomp


PROGRAM select_kinds
USE iso_Fortran_env
IMPLICIT NONE
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6, r=37)
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13,r=200)
REAL(kind=SGL) :: var1 = 0.
REAL(kind=DBL) :: var2 = 0._DBL
REAL(kind=REAL32) :: var3 = 1.
REAL(kind=REAL128) :: var4 = 1.
WRITE(*, 100) 'var1', KIND(var1), PRECISION(var1), RANGE(var1)
WRITE(*, 100) 'var2', KIND(var2), PRECISION(var2), RANGE(var2)
WRITE(*, 100) 'var3', KIND(var3), PRECISION(var3), RANGE(var3)
WRITE(*, 100) 'var4', KIND(var4), PRECISION(var4), RANGE(var4)
100 FORMAT (A, ': kind = ', I2, ', precision = ', I2, ', range = ', I4)
END PROGRAM select_kinds


Program abdulmalik
	IMPLICIT NONE
    INTEGER::n
    REAL::w(20),k,SUM_P_V
    print*,"enter n"
    read*,n
    call READ_REAL_VECROR(w,20,n)
    K = SUM_P_V(w,n,20)
    print*,k
END Program abdulmalik

SUBROUTINE READ_REAL_VECROR(w,s,n)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(out)::w(s)
    INTEGER::i
    do i=1,n
      print*,"enter w(i)"
      read*,w(i)
    enddo
END SUBROUTINE READ_REAL_VECROR

REAL FUNCTION SUM_P_V(w,n,s)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(in)::w(s)
    INTEGER::i,a=0
    REAL::sum=0,y
    do i=1,n
      y=w(i)
      if(Mod(y,2.)==1)then
         sum=sum+w(i)
         a=a+1
      endif
    enddo
    SUM_P_V=sum/a
end FUNCTION SUM_P_V

S2-ex2 Calculate Average of odd numbers Using Arrays.f95


module matrix_module
  implicit none

  type matrix
     integer :: shape(2)
     real, allocatable :: data(:,:)
   contains
     procedure :: construct
     procedure :: destruct
     procedure :: print
     procedure :: det
  end type matrix

contains

  subroutine construct(this, m, n)
    class(matrix) :: this
    integer :: m,n
    this%shape = [m,n]
    allocate(this%data(m,n))
  end subroutine construct

  subroutine destruct(this)
    class(matrix) :: this
    deallocate(this%data)
  end subroutine destruct

  ! print: formatted print of matrix
  subroutine print(this)
    class(matrix) :: this
    ! row_fmt: format character string for row printing
    ! fmt: temporary format string
    character(32) :: row_fmt, fmt = '(a,i0,a,i0,a,i0,a)'
    ! w: width of each entry printed
    ! d: number of decimal digits printed
    integer :: w, d = 2, row
    ! find largest width of element in matrix
    w = ceiling(log10(maxval(abs(this%data)))) + d + 2
    ! write row formatting to 'row_fmt' variable
    write(row_fmt,fmt) '(',this%shape(2),'(f',w,'.',d,',1x))'
    ! print matrix row by row
    do row = 1,this%shape(1)
       print row_fmt, this%data(row,:)
    end do
  end subroutine print

  ! det: compute determinant of matrix
  ! using recursive definition based on cofactors
  recursive function det(this) result(d)
    class(matrix) :: this
    type(matrix) :: submatrix
    real :: d, sgn, element, minor
    integer :: m, n, row, col, i, j

    m = this%shape(1)
    n = this%shape(2)
    d = 0.0

    ! compute cofactor
    ! if 1x1 matrix, return value
    if (m==1.and.n==1) then
       d = this%data(1,1)
    ! if square and not 1x1
    else if (m==n) then
       ! cofactor sum down the first column
       do row = 1,m
          ! sign of term
          sgn = (-1.0)**(row+1)
          ! matrix element
          element = this%data(row,1)
          ! construct the cofactor submatrix and compute its determinant
          call submatrix%construct(m-1,n-1)
          if (row==1) then
             submatrix%data = this%data(2:,2:)
          else if (row==m) then
             submatrix%data = this%data(:m-1,2:)
          else
             submatrix%data(:row-1,:) = this%data(:row-1,2:)
             submatrix%data(row:,:) = this%data(row+1:,2:)
          end if
          minor = submatrix%det()
          call submatrix%destruct()

          ! determinant accumulator
          d = d + sgn*element*minor
       end do
    end if
  end function det

  ! random_matrix: generate matrix with random entries in [-1,1]
  ! m,n: number of rows,cols
  function random_matrix(m,n) result(mat)
    integer :: m,n,i,j
    type(matrix) :: mat
    ! allocate memory for matrix
    call mat%construct(m,n)
    ! seed random number generator
    call srand(time())
    ! populate matrix
    do i = 1,m
       do j = 1,n
          mat%data(i,j) = 2.0*rand() - 1.0
       end do
    end do
  end function random_matrix

end module matrix_module


!+
MODULE SplineProcedures
! ------------------------------------------------------------------------------
! PURPOSE - Collect several procedures associated with spline functions that
!  are used in the NACA airfoil calculations.
! AUTHOR - Ralph L. Carmichael, Public Domain Aeronautical Software

! REVISION HISTORY
! DATE   PERSON      STATEMENT OF CHANGES
! 09Oct01  RLC   0.5   Original coding
! 24Nov01  RLC   0.6   Made a,fa... PRIVATE
! 05Dec01  RLC   0.7   Added material from Cubics and IntUtil
! 26Dec01  RLC   0.8   Made function values optional in PClookup and elsewhere
!  4Jan02  RLC   1.0   Final cleanup for release of PDAS 7
! 16Jan09  RLC   1.1   Additional cosmetic improvements

  IMPLICIT NONE
!-------------------------------------------------------------------------------
  CHARACTER(LEN=*),PARAMETER,PUBLIC:: &
    SPLINE_PROCEDURES_VERSION="1.1 (16 January 2009)"

  PRIVATE:: EvaluateCubic
  PUBLIC:: EvaluateCubicAndDerivs
  PUBLIC:: FMMspline
  PRIVATE:: InterpolatePolynomial
  PRIVATE:: LookUp
  PUBLIC:: PClookup
  PUBLIC:: SplineZero
  PUBLIC:: TableLookup
  PRIVATE:: Zeroin

!... Module-wide variables set in SplineZero and used by EvaluateCubic
  REAL,PRIVATE:: a,fa,fpa  ! a, f(a), f'(a)  at first point
  REAL,PRIVATE:: b,fb,fpb  ! b, f(b), f'(b)  at second point

CONTAINS

!+
PURE FUNCTION EvaluateCubic(u) RESULT(fu)
! ------------------------------------------------------------------------------
! PURPOSE - Evaluate a cubic polynomial defined by the function and the
!   1st derivative at two points
  REAL,INTENT(IN):: u   ! point where function is to be evaluated
  REAL:: fu                    ! computed value of f(u)

!  REAL:: a,fa,fpa   ! a, f(a), f'(a)  at first point
!  REAL:: b,fb,fpb   ! b, f(b), f'(b)  at second point

  REAL:: d,t,p
!-------------------------------------------------------------------------------
  d=(fb-fa)/(b-a)
  t=(u-a)/(b-a)
  p=1.0-t

  fu = p*fa + t*fb - p*t*(b-a)*(p*(d-fpa)-t*(d-fpb))
  RETURN
END Function EvaluateCubic   ! -------------------------------------------------

!+
PURE SUBROUTINE EvaluateCubicAndDerivs(a,fa,fpa, b,fb,fpb, u, f,fp,fpp,fppp)
! ------------------------------------------------------------------------------
! PURPOSE - Evaluate a cubic polynomial and its 1st, 2nd, and 3rd
!   derivatives at a specified point. The cubic is defined by the function
!   and the 1st derivative at two points. The cubic is mapped onto [0,1]
!   for some savings in computation. If no derivatives are wanted, it is
!   probably preferable to use functions EvaluateCubic above.

  REAL,INTENT(IN):: a,fa,fpa   ! a, f(a), f'(a)  at first point
  REAL,INTENT(IN):: b,fb,fpb   ! b, f(b), f'(b)  at second point
  REAL,INTENT(IN):: u   ! point where function is to be evaluated

  REAL,INTENT(OUT),OPTIONAL:: f,fp,fpp,fppp   ! f(u),f'(u),f''(u),f'''(u)

  REAL,PARAMETER:: ONE=1.0, TWO=2.0, THREE=3.0, SIX=6.0
! the "magic" matrix. This is how you declare a constant 4x4 matrix
  REAL,PARAMETER,DIMENSION(4,4):: MAGIC = RESHAPE(                      &
     & (/2.0, -3.0,  0.0,  1.0, -2.0,  3.0,  0.0,  0.0,                 &
     &   1.0, -2.0,  1.0,  0.0,  1.0, -1.0,  0.0,  0.0/), (/4,4/) )
  REAL,DIMENSION(4)::coef,rhs
  REAL:: h,t
! ------------------------------------------------------------------------------
  rhs(1)=fa
  rhs(2)=fb
  rhs(3)=fpa*(b-a)
  rhs(4)=fpb*(b-a)
  coef=MATMUL(MAGIC,rhs)

! CAUTION - these are not the coefficients of the cubic in the original
! coordinates. This is the cubic on [0,1] from the mapping t=(x-a)/(b-a).
! That is why the h terms appear in the derivatives.

  h=ONE/(b-a)
  t=(u-a)*h
  IF (Present(f)) THEN
    f=             coef(4) +     t*(coef(3) + t*(coef(2)   + t*coef(1)))
  END IF
  IF (Present(fp)) THEN
    fp=         h*(coef(3) + t*(TWO*coef(2) + t*THREE*coef(1)))
  END IF
  IF (Present(fpp)) THEN
    fpp=  h*h*(TWO*coef(2) +  t*SIX*coef(1))
  END IF
  IF (Present(fppp)) THEN
    fppp=h*h*h*SIX*coef(1)
  END IF
  RETURN
END Subroutine EvaluateCubicAndDerivs   ! -------------------------------------

!+
PURE SUBROUTINE FMMspline(x,y, yp)
! ------------------------------------------------------------------------------
! PURPOSE - Compute the cubic spline with endpoint conditions chosen
!    by FMM  (from the book by Forsythe,Malcolm & Moler)
  REAL,INTENT(IN),DIMENSION(:):: x,y
  REAL,INTENT(OUT),DIMENSION(:):: yp

  INTEGER:: i,n
  REAL,ALLOCATABLE,DIMENSION(:):: dx,dy,delta,dd,alpha,beta,sigma
  REAL:: deriv1,deriv2
!-------------------------------------------------------------------------------
  n=SIZE(x)   ! y and yp must be at least this size
  IF (n<2) THEN
    yp(1)=0.0
    RETURN
  END IF
  ALLOCATE(dx(n-1), dy(n-1), delta(n-1))
  dx(:)=x(2:n)-x(1:n-1)
  dy(:)=y(2:n)-y(1:n-1)
  delta(:)=dy(:)/dx(:)
  IF (n==2) THEN
    yp(1)=delta(1)
    yp(2)=delta(1)
    DEALLOCATE(dx,dy,delta)
    RETURN
  END IF
  ALLOCATE(dd(n-2))
  dd(:)=delta(2:n-1)-delta(1:n-2)
  IF (n==3) THEN
    deriv2=dd(1)/(x(3)-x(1))
    deriv1=delta(1)-deriv2*dx(1)
    yp(1)=deriv1
    yp(2)=deriv1+deriv2*dx(1)
    yp(3)=deriv1+deriv2*(x(3)-x(1))
    DEALLOCATE(dx,dy,delta,dd)
    RETURN
  END IF
! This gets rid of the trivial cases n=1,2,3. Assume from here on n>3

  ALLOCATE(alpha(n),beta(n),sigma(n))
  alpha(1)=-dx(1)
  alpha(2:n-1)=2.0*(dx(1:n-2)+dx(2:n-1))
  DO i=2,n-1                                                    ! serial loop
    alpha(i)=alpha(i)-dx(i-1)*dx(i-1)/alpha(i-1)            ! fwd elimination
  END DO
  alpha(n)=-dx(n-1)-dx(n-1)*dx(n-1)/alpha(n-1)

  beta(1)=dd(2)/(x(4)-x(2)) - dd(1)/(x(3)-x(1))
  beta(1)=beta(1)*dx(1)*dx(1)/(x(4)-x(1))

  beta(2:n-1)=dd(1:n-2)

  beta(n)=dd(n-2)/(x(n)-x(n-2)) - dd(n-3)/(x(n-1)-x(n-3))
  beta(n)=-beta(n)*dx(n-1)*dx(n-1)/(x(n)-x(n-3))

  DO i=2,n                                                    ! serial loop
    beta(i)=beta(i)-dx(i-1)*beta(i-1)/alpha(i-1)          ! fwd elimination
  END DO

  sigma(n)=beta(n)/alpha(n)
  DO i=n-1,1,-1                                 ! reverse order serial loop
    sigma(i)=(beta(i)-dx(i)*sigma(i+1))/alpha(i)        ! back substitution
  END DO

  yp(1:n-1)=delta-dx*(sigma(1:n-1)+sigma(1:n-1)+sigma(2:n))
  yp(n)=yp(n-1)+dx(n-1)*3.0*(sigma(n)+sigma(n-1))

  DEALLOCATE(dx,dy,delta, alpha,beta,sigma, dd)

  RETURN
END SUBROUTINE FMMspline   ! ---------------------------------------------------

!+
PURE FUNCTION InterpolatePolynomial(x,y,u) RESULT(sum)
! ------------------------------------------------------------------------------
! PURPOSE -Compute the value of the interpolating polynomial thru
!   x- and y-arrays at the x-value of u, using Lagrange's equation.

  REAL,INTENT(IN),DIMENSION(:):: x,y   ! tables of coordinates
  REAL,INTENT(IN):: u   ! value of x-coordinate for interpolation
  REAL:: sum
  INTEGER:: i,j
  REAL:: fact
  REAL,DIMENSION(SIZE(x)):: du
!-------------------------------------------------------------------------------
  du(:)=u-x(:)
  sum=0.0
  DO j=1,SIZE(x)
    fact=1.0
    DO i=1,SIZE(x)
      IF (i /= j) fact=fact*du(i)/(x(j)-x(i))
    END DO
    sum=sum+y(j)*fact
  END DO
  RETURN
END Function InterpolatePolynomial   ! -----------------------------------------

!+
PURE FUNCTION Lookup(xtab,x) RESULT (i)
! ------------------------------------------------------------------------------
! PURPOSE - Search a sorted (increasing) array to find the interval
!  bounding a given number. If n is the size of the array a,
!  return 0 if number x is < a(1)
!  return n if x > a(n).
!  return i if  a(i) <= x < a(i+1).
!  If x is exactly equal to a(n), return n-1.

  REAL,INTENT(IN),DIMENSION(:)::  xtab    ! input array
  REAL,INTENT(IN):: x  ! input number

  INTEGER:: i  ! index of interval such that xtab(i) <= x < xtab(i+1)
               ! =0 if x < xtab(1) and =n if x > xtab(i)
  INTEGER:: j,k,n
!-------------------------------------------------------------------------------
  n=SIZE(xtab)
  IF (n <= 0) THEN
    i=-1
    RETURN
  END IF

  IF (x < xtab(1)) THEN
    i=0
    RETURN
  END IF

  IF (x > xtab(n)) THEN
    i=n
    RETURN
  END IF

  i=1
  j=SIZE(xtab)
  DO
    IF (j <= i+1) EXIT
    k=(i+j)/2                                     ! integer division
    IF (x < xtab(k)) THEN
      j=k
    ELSE
      i=k
    END IF
  END DO

  RETURN
END Function Lookup   ! --------------------------------------------------------

!+
SUBROUTINE PClookup(x,y,yp, u, f,fp,fpp,fppp)
! ------------------------------------------------------------------------------
! PURPOSE - Interpolate in a cubic spline at one point
  REAL,INTENT(IN),DIMENSION(:):: x,y,yp   ! defines the cubic spline
  REAL,INTENT(IN):: u   ! point where spline is to be evaluated
  REAL,INTENT(OUT),OPTIONAL:: f,fp,fpp,fppp   ! f(u),f'(u), f''(u), f'''(u)

  REAL:: ud, a,fa,fpa, b,fb,fpb
  REAL:: z,zp,zpp,zppp
  INTEGER:: k
!-------------------------------------------------------------------------------
  k=LookUp(x,u)
  k=MAX(1, MIN(SIZE(x)-1,k) )
  a=x(k)
  fa=y(k)
  fpa=yp(k)
  b=x(k+1)
  fb=y(k+1)
  fpb=yp(k+1)
  ud=u
  CALL EvaluateCubicAndDerivs(a,fa,fpa, b,fb,fpb, ud, z,zp,zpp,zppp)
  IF(Present(f)) f=z
  IF(Present(fp)) fp=zp
  IF(Present(fpp)) fpp=zpp
  IF(Present(fppp)) fppp=zppp

  RETURN
END Subroutine PClookup   ! ----------------------------------------------------

!+
SUBROUTINE SplineZero(x,f,fp, fbar,tol, xbar,errCode)
! ------------------------------------------------------------------------------
! PURPOSE - Find a value of x corresponding to a value of fbar of the cubic
!  spline defined by arrays x,f,fp. f is the value of the spline at x and fp
!  is the first derivative.
! NOTES - The spline is searched for an interval that crosses the specified
!   value. Then Brent's method is used for finding the zero.

  IMPLICIT NONE
  REAL,INTENT(IN),DIMENSION(:):: x,f,fp
  REAL,INTENT(IN):: fbar
  REAL,INTENT(IN):: tol
  REAL,INTENT(OUT):: xbar
  INTEGER,INTENT(OUT):: errCode

  INTEGER:: k,n
  REAL,ALLOCATABLE,DIMENSION(:):: fLocal
  REAL,PARAMETER:: ZERO=0.0
!-------------------------------------------------------------------------------
  n=SIZE(x)

  DO k=1,n   ! look for an exact match. Could happen...
    IF (ABS(f(k)-fbar) < tol) THEN
      xbar=x(k)
      errCode=0
      RETURN
    END IF
  END DO

  ALLOCATE(fLocal(n))
  fLocal(1:n)=f(1:n)-fbar   ! look for a zero of fLocal

  DO k=2,n
   IF ( fLocal(k-1)*fLocal(k) < ZERO) EXIT
  END DO
  IF (k==n+1) THEN   ! no crossing could be found
    errCode=1
    DEALLOCATE(fLocal)
    RETURN
  END IF

  errCode=0
  a=x(k-1)    ! set the global variables for EvaluateCubic
  fa=fLocal(k-1)
  fpa=fp(k-1)
  b=x(k)
  fb=fLocal(k)
  fpb=fp(k)
  DEALLOCATE(fLocal)

  xbar=Zeroin(a,b,EvaluateCubic,tol)

  RETURN
END Subroutine SplineZero   ! --------------------------------------------------

!+
PURE FUNCTION TableLookup(x,y,order,u) RESULT(fu)
! ------------------------------------------------------------------------------
! PURPOSE - Use polynomial evaluation for table lookup. Find points ahead
!   and behind evaluation point to match order of interpolation desired.

  REAL,INTENT(IN),DIMENSION(:):: x,y   ! data tables
  INTEGER,INTENT(IN):: order   ! order of interpolation
                               ! (1=linear, 2=quadratic...)
  REAL,INTENT(IN):: u          ! x-coor where function is to be evaluated
  REAL:: fu                    ! interpolated function value
  INTEGER:: j,m
!-------------------------------------------------------------------------------
  m=MIN(order+1, SIZE(x))  ! number of points used for interpolating poly
  j=Lookup(x,u)
  j=j-(m/2-1)
  j=MIN(1+SIZE(x)-m, j)                       ! j+m-1 must not exceed SIZE(x)
  j=MAX(1,j)                                  ! j must be positive
                       ! use points j thru j+m-1 for interpolation (m points)
  fu=InterpolatePolynomial(x(j:j+m-1),y(j:j+m-1),u)
  RETURN
END Function TableLookup   ! ---------------------------------------------------

!+
      FUNCTION Zeroin (ax,bx,f,tol) RESULT(z)
! ------------------------------------------------------------------------------
! PURPOSE - Compute a zero of f in the interval (ax,bx)
! AUTHORS - Van Winjngaarden,Decker,Brendt, et al
!           Forsythe, Malcolm, & Moler,
!           Press, et.al, Numerical Recipes
!           Ralph L. Carmichael, Public Domain Aeronautical Software

!     REVISIONS - DATE   PERSON      STATEMENT OF CHANGES

      IMPLICIT NONE
      REAL,INTENT(IN):: ax,bx   ! left and right endpoints of interval
      REAL,INTENT(IN):: tol     ! desired interval of uncertainity

      REAL:: z

      INTERFACE
        FUNCTION F(x) RESULT(g)
          IMPLICIT NONE
          REAL,INTENT(IN):: x
          REAL:: g
        END Function F
      END INTERFACE

      INTEGER,PARAMETER:: MAX_ITER=500
      INTEGER:: k
      REAL,PARAMETER:: ZERO=0.0, ONE=1.0, TWO=2.0, THREE=3.0, HALF=0.5
      REAL:: a,b,c,d,e,eps,fa,fb,fc,tol1,xm,p,q,r,s
!-------------------------------------------------------------------------------
      eps=EPSILON(ax)
!      tol1=ONE+eps

      a=ax   ! initialization
      b=bx
      fa=f(a)
      fb=f(b)   ! should test that fa and fb have opposite signs
      c=b
      fc=fb

      DO k=1,MAX_ITER   ! begin iteration

        IF ((fb > ZERO .AND. fc > ZERO) .OR. (fb < ZERO .AND. fc < ZERO)) THEN
          c=a
          fc=fa
          d=b-a
          e=d
        END IF

        IF (ABS(fc) < ABS(fb)) THEN
          a=b
          b=c
          c=a
          fa=fb
          fb=fc
          fc=fa
        END IF

        tol1=TWO*eps*ABS(b) + HALF*tol   ! convergence test
        xm=0.5*(c-b)
        IF (ABS(xm)<=tol1 .OR. fb==0.0) THEN
          z=b
          RETURN   ! the only way out!
        END IF

!.....is bisection necessary?...........................................
        IF (ABS(e)<=tol1 .AND. ABS(fa)>ABS(fb)) THEN
          s=fb/fa   ! is quadratic interpolation possible ?
          IF (a==c) THEN
            s=fb/fa   ! use linear interpolation
            p=TWO*xm*s
            q=ONE-s
          ELSE
            q=fa/fc   ! use inverse quadratic interpolation
            r=fb/fc
            s=fb/fa
            p=s*(TWO*xm*q*(q-r)-(b-a)*(r-ONE))
            q=(q-ONE)*(r-ONE)*(s-ONE)
          END IF

          IF (p > ZERO) q=-q   ! adjust signs
          p=ABS(p)

          IF (p+p < MIN(THREE*xm*q-ABS(tol1*q),ABS(e*q))) THEN
            e=d    ! use interpolation
            d=p/q
          ELSE
            d=xm   ! use bisection
            e=d
          END IF
        ELSE
          d=xm   ! use bisection
          e=d
        END IF

        a=b
        fa=fb
        IF (ABS(d)> tol1) THEN
          b=b+d
        ELSE
          b=b+SIGN(TOL1,XM)
        END IF
        fb=f(b)

      END DO

      z=b   ! but this is a bad return. Max iterations exceeded.
      RETURN
      END Function Zeroin   ! --------------------------------------------------

END Module SplineProcedures   ! ================================================


module mod_statistics
    use mod_types
    use random
    implicit none

    contains

    ! Random number generation
    function rnorm(mu, sigma)
        real(kind=r2), intent(in) :: mu, sigma
        real(kind=r2) :: z
        real(kind=r2) :: rnorm

        rnorm = mu + random_normal() * sigma
        return
    end function

    function rgamma(shp, scl)
        ! NOTE: random_gamma takes real(4) as argument for shape.
        ! Therefore, coerce real(8) (r2) argument `shp` to real(4) (r1)
        ! by copying.
        real(kind=r2), intent(in) :: shp, scl
        real(kind=r1) :: shp2
        real(kind=r2) :: rgamma

        shp2 = shp
        rgamma = random_gamma(shp2, .true.) * scl
        return
    end function

    ! Density calculation
    function ldnorm(x, mu, sigma)
        real(kind=r2), intent(in) :: x, mu, sigma
        real(kind=r2) :: hlog2pi, lsig, xm, s2, ex
        real(kind=r2) :: ldnorm

        hlog2pi = -0.39908993417 !! -0.5 * log(2pi)
        lsig = -log(sigma)
        xm = x - mu
        s2 = 2 * sigma * sigma
        ex = -xm * xm / s2
        ldnorm = hlog2pi + lsig + ex
        return
    end function

end module