!Calculate the portion of the writhe that changes during a segment slide move

subroutine writhe_slide(R, IT1, IT2, N, Wr)
   use params, only: dp
   implicit none

   real(dp), PARAMETER :: PI = 3.141592654d0 ! Value of pi

   integer, intent(in) :: N                 ! Number of beads
   real(dp), intent(in) :: R(3, N)  ! PositionS
   !Geometric variables
   real(dp) r1(3)                  ! Position bead 1
   real(dp) r2(3)                  ! Position bead 2
   real(dp) r12(3)                 ! Relative position vector
   real(dp) s1                     ! Length of segment 1
   real(dp) s2                     ! Length of segment 2
   real(dp) e1(3)                  ! Tangent of first segment
   real(dp) e2(3)                  ! Tangent of second segment
   real(dp) e3(3)
   integer DIB                             !Number of segments inside segment moved
   integer DIO                              !Number of segments unchanged by move

   !Counter variables
   integer IT1, IT2, II, IO, IS1, IS2
   integer I, IP1, IS1P1, IS2P1
   integer J, JP1

   real(dp) dWr
   real(dp), intent(out) :: Wr      ! Writhe

   Wr = 0.
   if (IT2 >= IT1) then
      DIB = IT2 - IT1
   else
      DIB = (N - IT1) + IT2
   ENDif
   DIO = N - DIB - 2
   IS1P1 = IT1                                ! Index of first stretched (or compressed) segment (not inside beads moved)
   IS2 = IT2                                  ! Index of second stretched (or compressed) segment (not inside beads moved)

   if (IS1P1 == 1) then
      IS1 = N
   else
      IS1 = IS1P1 - 1
   ENDif

   if (IS2 == N) then
      IS2P1 = 1
   else
      IS2P1 = IS2 + 1
   ENDif

   II = IT1

   if (IT1 /= IT2) then
      !Sum over segments inside segment slid (inner segments)
      do I = 1, DIB

         if (II == N) then
            IP1 = 1
         elseif (II == N + 1) then
            II = 1
            IP1 = II + 1
         else
            IP1 = II + 1
         ENDif
         IO = IT2 + 1
         !Sum over segments unchanged by slide (outer segments)
         do J = 1, DIO

            if (IO == N) then
               JP1 = 1
            elseif (IO == N + 1) then
               IO = 1
               JP1 = IO + 1
            else
               JP1 = IO + 1
            ENDif

            !Calculate Gauss integeral between outer segment and inner segment

            r2 = R(:, IO)
            r1 = R(:, II)
            r12 = r2 - r1

            s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
            s1 = SQRT(SUM((R(:, IP1) - R(:, II))**2))
            e2 = (R(:, JP1) - R(:, IO))/s2
            e1 = (R(:, IP1) - R(:, II))/s1

            CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
            !Writhe = 0 between segments in plane (dWr = NaN)
            if (dWr /= dWr) then
               dWr = 0.
            endif
            !Writhe = 0 between adjacent segments
            if (JP1 == II .OR. IP1 == IO) then
               dWr = 0.
            endif

            Wr = Wr + dWr

            if (I == 1) then

               !Calculate Gauss integeral between outer segment and first stretched segment

               r2 = R(:, IO)
               r1 = R(:, IS1)

               r12 = r2 - r1

               s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
               s1 = SQRT(SUM((R(:, IS1P1) - R(:, IS1))**2))
               e2 = (R(:, JP1) - R(:, IO))/s2
               e1 = (R(:, IS1P1) - R(:, IS1))/s1

               CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
               !Writhe = 0 between segments in plane (dWr = NaN)
               if (dWr /= dWr) then
                  dWr = 0.
               endif
               !Writhe = 0 between adjacent segments
               if (JP1 == IS1 .OR. IS1P1 == IO) then
                  dWr = 0.
               endif

               Wr = Wr + dWr

               !Calculate Gauss integeral between outer segment and second stretched segment
               r2 = R(:, IO)
               r1 = R(:, IS2)

               r12 = r2 - r1

               s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
               s1 = SQRT(SUM((R(:, IS2P1) - R(:, IS2))**2))
               e2 = (R(:, JP1) - R(:, IO))/s2
               e1 = (R(:, IS2P1) - R(:, IS2))/s1

               CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
               !Writhe = 0 between segments in plane (dWr = NaN)
               if (dWr /= dWr) then
                  dWr = 0.
               endif
               !Writhe = 0 between adjacent segments
               if (JP1 == IS2 .OR. IS2P1 == IO) then
                  dWr = 0.
               endif
               Wr = Wr + dWr
            ENDif

            IO = IO + 1

         ENDdo

         !Calculate Gauss integral between inner segment and first stretched segment

         r2 = R(:, II)
         r1 = R(:, IS1)

         r12 = r2 - r1

         s2 = SQRT(SUM((R(:, IP1) - R(:, II))**2))
         s1 = SQRT(SUM((R(:, IS1P1) - R(:, IS1))**2))
         e2 = (R(:, IP1) - R(:, II))/s2
         e1 = (R(:, IS1P1) - R(:, IS1))/s1

         CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
         !Writhe = 0 between segments in plane (dWr = NaN)
         if (dWr /= dWr) then
            dWr = 0.
         endif
         !Writhe = 0 between adjacent segments
         if (IP1 == IS1 .OR. IS1P1 == II) then
            dWr = 0.
         endif

         Wr = Wr + dWr

         !Calculate Gauss integral between inner segment and second stretched segment
         r2 = R(:, II)
         r1 = R(:, IS2)

         r12 = r2 - r1

         s2 = SQRT(SUM((R(:, IP1) - R(:, II))**2))
         s1 = SQRT(SUM((R(:, IS2P1) - R(:, IS2))**2))
         e2 = (R(:, IP1) - R(:, II))/s2
         e1 = (R(:, IS2P1) - R(:, IS2))/s1

         CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
         !Writhe = 0 between segments in plane (dWr = NaN)
         if (dWr /= dWr) then
            dWr = 0.
         endif
         !Writhe = 0 between adjacent segments
         if (IP1 == IS2 .OR. IS2P1 == II) then
            dWr = 0.
         endif
         Wr = Wr + dWr

         II = II + 1
      ENDdo
   ENDif

   ! calculate Gauss integral  between two stretched segments
   r2 = R(:, IS2)
   r1 = R(:, IS1)

   r12 = r2 - r1

   s2 = SQRT(SUM((R(:, IS2P1) - R(:, IS2))**2))
   s1 = SQRT(SUM((R(:, IS1P1) - R(:, IS1))**2))
   e2 = (R(:, IS2P1) - R(:, IS2))/s2
   e1 = (R(:, IS1P1) - R(:, IS1))/s1

   CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
   !Writhe = 0 between segments in plane (dWr = NaN)
   if (dWr /= dWr) then
      dWr = 0.
   endif
   !Writhe = 0 between adjacent segments
   if (IS2P1 == IS1 .OR. IS1P1 == IS2) then
      dWr = 0.
   endif
   WR = WR + DWR

   if (IT1 == IT2) then
      !If IT1 == IT2, Get writhe between segment unaffected by move and two segments affected

      IO = IT1 + 1
      !Sum over segments unchanged by slide (outer segments)
      do J = 1, DIO

         if (IO == N) then
            JP1 = 1
         elseif (IO == N + 1) then
            IO = 1
            JP1 = IO + 1
         else
            JP1 = IO + 1
         ENDif

         !Calculate Gauss integeral between outer segment and first stretched segment

         r2 = R(:, IO)
         r1 = R(:, IS1)

         r12 = r2 - r1

         s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
         s1 = SQRT(SUM((R(:, IS1P1) - R(:, IS1))**2))
         e2 = (R(:, JP1) - R(:, IO))/s2
         e1 = (R(:, IS1P1) - R(:, IS1))/s1

         CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
         !Writhe = 0 between segments in plane (dWr = NaN)
         if (dWr /= dWr) then
            dWr = 0.
         endif
         !Writhe = 0 between adjacent segments
         if (JP1 == IS1 .OR. IS1P1 == IO) then
            dWr = 0.
         endif

         Wr = Wr + dWr

         !Calculate Gauss integeral between outer segment and second stretched segment
         r2 = R(:, IO)
         r1 = R(:, IS2)

         r12 = r2 - r1

         s2 = SQRT(SUM((R(:, JP1) - R(:, IO))**2))
         s1 = SQRT(SUM((R(:, IS2P1) - R(:, IS2))**2))
         e2 = (R(:, JP1) - R(:, IO))/s2
         e1 = (R(:, IS2P1) - R(:, IS2))/s1

         CALL gauss_pair(R1, R2, e1, e2, s1, s2, dWr)
         !Writhe = 0 between segments in plane (dWr = NaN)
         if (dWr /= dWr) then
            dWr = 0.
         endif
         !Writhe = 0 between adjacent segments
         if (JP1 == IS2 .OR. IS2P1 == IO) then
            dWr = 0.
         endif

         Wr = Wr + dWr
         IO = IO + 1
      ENDdo
   ENDif

   Wr = 2.*Wr

   RETURN
END subroutine writhe_slide


      SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix product U' * U or L * L', where U and L are
C     upper and lower triangular matrices, respectively, stored in the
C     corresponding upper or lower triangular part of the array A.
C
C     If UPLO = 'U' then the upper triangle of the result is stored,
C     overwriting the matrix U in A.
C     If UPLO = 'L' then the lower triangle of the result is stored,
C     overwriting the matrix L in A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle (U or L) is given in the array A,
C             as follows:
C             = 'U':  the upper triangular part U is given;
C             = 'L':  the lower triangular part L is given.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the triangular matrices U or L.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular matrix U.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular matrix L.
C             On exit, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array contains the upper
C             triangular part of the product U' * U. The strictly lower
C             triangular part is not referenced.
C             On exit, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array contains the lower
C             triangular part of the product L * L'. The strictly upper
C             triangular part is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix product U' * U or L * L' is computed using BLAS 3
C     operations as much as possible (a block algorithm).
C
C     FURTHER COMMENTS
C
C     This routine is a counterpart of LAPACK Library routine DLAUUM,
C     which computes the matrix product U * U' or L' * L.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IB, II, NB
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DSYRK, DTRMM, MB01XY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01XD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Determine the block size for this environment (as for DLAUUM).
C
      NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 )
C
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
C
C        Use unblocked code.
C
         CALL MB01XY( UPLO, N, A, LDA, INFO )
      ELSE
C
C        Use blocked code.
C
         IF( UPPER ) THEN
C
C           Compute the product U' * U.
C
            DO 10 I = N, 1, -NB
               IB = MIN( NB, I )
               II = I - IB + 1
               IF( I.LT.N ) THEN
                  CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit',
     $                        IB, N-I, ONE, A( II, II ), LDA,
     $                        A( II, II+IB ), LDA )
                  CALL DGEMM( 'Transpose', 'No transpose', IB, N-I,
     $                        I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ),
     $                        LDA, ONE, A( II, II+IB ), LDA )
               END IF
               CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO )
               CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE,
     $                     A( 1, II ), LDA, ONE, A( II, II ), LDA )
   10       CONTINUE
         ELSE
C
C           Compute the product L * L'.
C
            DO 20 I = N, 1, -NB
               IB = MIN( NB, I )
               II = I - IB + 1
               IF( I.LT.N ) THEN
                  CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit',
     $                        N-I, IB, ONE, A( II, II ), LDA,
     $                        A( II+IB, II ), LDA )
                  CALL DGEMM( 'No transpose', 'Transpose', N-I, IB,
     $                        I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ),
     $                        LDA, ONE, A( II+IB, II ), LDA )
               END IF
               CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO )
               CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE,
     $                     A( II, 1 ), LDA, ONE, A( II, II ), LDA )
   20       CONTINUE
         END IF
      END IF
C
      RETURN
C
C *** Last line of MB01XD ***
      END


C$Procedure      SHARPR ( Sharpen a rotation )

      SUBROUTINE SHARPR ( ROT )

C$ Abstract
C
C     Given a matrix that is "nearly" a rotation, adjust the columns
C     (from left to right in the usual printed presentation of a matrix)
C     so that the columns are numerically unit length and orthogonal.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      IMPLICIT NONE
      DOUBLE PRECISION      ROT ( 3, 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     ROT       I/O  The rotation matrix to be sharpened.
C
C$ Detailed_Input
C
C     ROT       a 3x3 matrix that is nearly a rotation matrix.
C
C$ Detailed_Output
C
C     ROT       the input after sharpening the columns.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) This routine is not meant to be used on singular or near-
C        singular matrices (in other words, matrices with determinant
C        close to zero).
C
C        If the input matrix is singular, the output matrix may not
C        be a rotation matrix.  In any case, the results should be
C        considered unreliable in this case.
C
C        No error handling is done for invalid input matrices.
C
C$ Particulars
C
C     This routine "sharpens" the orthogonality of a potential
C     rotation matrix.  It is intended for use in those situations
C     in which you have a rotation matrix that may be derived
C     from single precision inputs or that may have experienced
C     round off errors in its construction.
C
C$ Examples
C
C     Suppose that you have a rotation matrix that needs to be
C     converted to a quaternion.  The SPICE matrix to quaternion
C     conversion routine M2Q performs error checks on the input
C     matrix and signals an error if it does not meet the checks
C     for a quaternion.  By calling this routine you can ensure that
C     your rotation matrix (provided it's non-singular) will pass
C     the restrictions imposed by M2Q.
C
C         CALL SHARPR ( ROT )
C         CALL M2Q    ( ROT, Q )
C
C$ Restrictions
C
C     See the Exceptions section above.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 13-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHAT call.  Some header updates were made.
C
C-    SPICELIB Version 1.0.0, 16-SEP-1999 (WLT)
C
C
C-&

C$ Index_Entries
C
C     Sharpen the orhogonality of the columns of a rotation
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 13-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VHAT call. Some header updates were made.
C
C-&

C
C     Unitize the first column of the rotation.
C
      CALL VHATIP ( ROT(1,1) )

C
C     Unitize the third column of the rotation and make it
C     orthogonal to the first two columns.
C
      CALL UCRSS ( ROT(1,1),  ROT(1,2),  ROT(1,3) )

C
C     Unitize the second column of the rotation and make it
C     orthogonal to the first and third columns.
C
      CALL UCRSS ( ROT(1,3),  ROT(1,1),  ROT(1,2) )

      RETURN
      END


!=======================================================================
      SUBROUTINE ADDABS(A, INDROW, INDCOL, IUPPER, NZER, TM, TP, N, LIM, HIEND&
         , KPASS, NNCV, BASIS, AB, S)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!=======================================================================
!       Called by: DVDRVR, SETUP
!
!       Calculates the new column in the D matrix and the new column
!       in the S matrix. The new D column is D(new)=AB(new). S has a
!       new row and column, but being symmetric only the new column is
!       stored. S(i,kpass+1)=B(i)^T D(kpass+1) for all i.
!
!       subroutines called:
!       OP, DDOT, DSCAL
!-----------------------------------------------------------------------
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:22  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dssbmv_I
      USE dscal_I
      USE ddot_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: NZER
      INTEGER  :: N
      INTEGER , INTENT(IN) :: LIM
      INTEGER , INTENT(IN) :: KPASS
      INTEGER  :: NNCV
      LOGICAL  :: IUPPER
      LOGICAL , INTENT(IN) :: HIEND
      INTEGER  :: INDROW(NZER)
      INTEGER  :: INDCOL(N)
      REAL(DOUBLE)  :: A(NZER)
      REAL(DOUBLE)  :: TM(N)
      REAL(DOUBLE)  :: TP(N)
      REAL(DOUBLE)  :: BASIS(N*LIM)
      REAL(DOUBLE)  :: AB(N*LIM)
      REAL(DOUBLE) , INTENT(OUT) :: S(LIM*(LIM + 1)/2)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IDSTART, ISSTART, IV, IBSTART, IBV
      REAL(DOUBLE) :: SS
!-----------------------------------------------
!        EXTERNAL OP
!-----------------------------------------------------------------------
!   on entry
!   -------
!   N           The order of the matrix A
!   kpass       The current dimension of the expanding sub-basis
!   NNCV        Number of new basis vectors.
!   Basis       the basis vectors, including the new NNCV ones.
!   on exit
!   -------
!   AB          The new matrix D=AB. (with new NNCV columns)
!   S           The small matrix with NNCV new columns at the last part
!-----------------------------------------------------------------------
!
! The user specified matrix-vector routine is called with the new
! basis vector B(*,kpass+1) and the result is assigned to AB(idstart)
!
      IDSTART = KPASS*N + 1
      CALL DSSBMV (A, INDROW, INDCOL, IUPPER, NZER, TM, TP, N, NNCV, BASIS(&
         IDSTART), AB(IDSTART))
!
! If highest pairs are sought, use the negative of the matrix
!
      IF (HIEND) CALL DSCAL (N*NNCV, -1.D0, AB(IDSTART), 1)
!
! The new S is calculated by adding the new last columns
! S(new)=B^T D(new).
!
      ISSTART = KPASS*(KPASS + 1)/2
      DO IV = 1, NNCV
         IBSTART = 1
         DO IBV = 1, KPASS + IV
            SS = DDOT(N,BASIS(IBSTART),1,AB(IDSTART),1)
            S(ISSTART+IBV) = SS
            IBSTART = IBSTART + N
         END DO
         ISSTART = ISSTART + KPASS + IV
         IDSTART = IDSTART + N
      END DO

      RETURN
      END SUBROUTINE ADDABS


C  (C) Copr. 1986-92 Numerical Recipes Software ,2:-5K#R..
      SUBROUTINE convlv(data,respns,n,isign,ans,fft)
CU    USES realft,twofft
      INTEGER*4 isign,n
      INTEGER*4 i,no2
      REAL*4    data(n),respns(n)
      COMPLEX*8 ans(n)
      COMPLEX*8 fft(n)
      call twofft(data,respns,fft,ans,n)

      no2=n/2
      if (isign.eq.1) then               ! convolution
        do i=1,no2+1
          ans(i)=fft(i)*ans(i)/no2
        end do
      else if (isign.eq.-1) then         ! deconvolution
        do i=1,no2+1
           if (abs(ans(i)).eq.0.0) pause
     *        'deconvolving at response zero in convlv'
           ans(i)=fft(i)/ans(i)/no2
        end do
      else
          pause 'no meaning for isign in convlv'
      endif
      ans(1)=cmplx(real(ans(1)),real(ans(no2+1)))
      call realft(ans,n,-1)
      return
      END


c
c***********************************************
c
        subroutine filtcor(x,nch,nfrq,idl,rnrmt,nd,areg,npw,nn,lfd)
c    divides fourier coefficients by transfer function of filters
c    uses table calculated by routine fcorsu

c       replaces routine rnormc
        integer npw(*)
        real x(nch,2,nfrq),areg(nch,*)
        logical lfd(nch,*)
        complex t,rnrmt(nch,nd,*),xcor,wr   !w,
c        print*,'a1= ',areg(1,1),'  a2= ',areg(1,2)
c        print*,'a3= ',areg(1,3),'  a4= ',areg(1,4)
        pian=2.*3.141592654/nn
        do 10 i=1,nfrq
           do 5 j=1,nch
             if(lfd(j,idl)) then
                xcor=(1.,0.)
             else
                xcor=(0.,0.)
                   do 3 k=1,npw(j)
                   wr=cmplx(0.,(npw(j)-k)*pian*i)
                   xcor=xcor+areg(j,k)*cexp(wr)
 3                 continue
             end if
           t=rnrmt(j,idl,i)*cmplx(x(j,1,i),x(j,2,i))/xcor
           x(j,1,i)=real(t)
           x(j,2,i)=aimag(t)
5          continue

10      continue
        return
        end


program bench_advection
  implicit none
  integer, parameter :: nx = 100
  integer, parameter :: nt = 100
  integer, parameter :: nr = 500

  double precision, parameter :: pi = 4.0*atan(1.0)
  double precision :: q_init(nx)

  double precision, parameter :: dt = 0.125
  double precision :: jacobian(nx,nx)

  integer :: i

  do i = 1, nx
     q_init(i) = (0.5d0+0.5d0*sin(((i-1)*2d0*pi)/(nx-1.5d0)))+0.0001d0
  end do

  do i = 1, nr
     call doit(q_init, jacobian)
     if (i == 1) then
        write(*,*) jacobian(1,1:5)
        write(*,*) jacobian(2,1:5)
        write(*,*) jacobian(3,1:5)
        write(*,*) jacobian(4,1:5)
        write(*,*) jacobian(5,1:5)
     end if
  end do

contains

  subroutine doit(q_init_values, jacobian)
    use adjac
    implicit none
    double precision, intent(in) :: q_init_values(nx)
    double precision, intent(out) :: jacobian(nx,nx)

    type(adjac_double) :: q_init(nx), q(nx)

    call adjac_reset()
    call adjac_set_independent(q_init, q_init_values)

    call toon(nt, dt, q_init, q)
    call adjac_get_dense_jacobian(q, jacobian)
  end subroutine doit

  subroutine lax_wendroff(nt, c, q_init, q)
    use adjac
    implicit none
    integer, intent(in) :: nt
    double precision, intent(in) :: c
    type(adjac_double), intent(in) :: q_init(nx)
    type(adjac_double), intent(inout) :: q(nx)

    type(adjac_double) :: flux(nx-1)
    integer :: i, j

    do i = 1, nx
       q(i) = q_init(i)
    end do

    do j = 1, nt
       do i = 1, nx-1
          flux(i) = 0.5d0*c*(q(i)+q(i+1)+c*(q(i)-q(i+1)))
       end do
       do i = 2, nx-1
          q(i) = q(i) + flux(i-1) - flux(i)
       end do
       q(1) = q(nx-1)
       q(nx) = q(2)
    end do
  end subroutine lax_wendroff

  subroutine toon(nt, c, q_init, q)
    use adjac
    implicit none
    integer, intent(in) :: nt
    double precision, intent(in) :: c
    type(adjac_double), intent(in) :: q_init(nx)
    type(adjac_double), intent(inout) :: q(nx)

    type(adjac_double) :: flux(nx-1)
    integer :: i, j

    do i = 1, nx
       q(i) = q_init(i)
    end do

    do j = 1, nt
       do i = 1, nx-1
          flux(i) = (exp(c*log(q(i)/q(i+1)))-1.0d0) * q(i)*q(i+1) / (q(i)-q(i+1))
       end do
       do i = 2, nx-1
          q(i) = q(i) + flux(i-1) - flux(i)
       end do
       q(1) = q(nx-1)
       q(nx) = q(2)
    end do
  end subroutine toon
end program bench_advection


!>
program main

  use hydrogen
  use vmatrix

  implicit none

  ! hydrogen basis parameters
  integer :: l
  double precision :: alpha
  integer :: n_b

  ! scattering parameters
  double precision :: energy

  ! radial grid variables
  integer :: n_r
  double precision :: d_r, r_max
  double precision , allocatable :: r_grid(:)
  double precision , allocatable :: r_weights(:)

  ! momentum grid variables
  integer :: n_k
  double precision :: d_k, k_max
  double precision , allocatable :: k_grid(:)

  ! hydrogen state variables
  double precision , allocatable :: wf(:, :)
  double precision , allocatable :: energies(:)

  ! v-matrix elements
  double precision , allocatable :: V_direct(:, :)
  double precision , allocatable :: V_exchange(:, :)

  ! v-matrix on-shell elements
  double precision , allocatable :: on_direct(:, :)
  double precision , allocatable :: on_exchange(:, :)

  ! local variables
  integer :: status
  integer :: i_r, i_k, i_f, i_i

!> program execution
  write (*, *) "[debug] program start"

  status = 0

  ! read input
  write (*, *) "[debug] reading input"

  call read_input(l, alpha, n_b, d_r, r_max, d_k, k_max, energy, status)
  if (status /= 0) call exit(status)

  ! validate input
  write (*, *) "[debug] validating input"

  if (l < 0) status = 1
  if (alpha < 0.0d0) status = 1
  if (n_b < 0) status = 1
  if (d_r < 0.0d0) status = 1
  if (r_max < 0.0d0) status = 1
  if (d_k < 0.0d0) status = 1
  if (k_max < 0.0d0) status = 1
  if (energy < 0.0d0) status = 1
  if (status /= 0) call exit(status)

  ! scale energy from eV to atomic units
  write (*, *) "[debug] scaling energy from [eV] to [Ha]"

  energy = energy / 27.2113862459d0

  ! determine number of radial and momentum grid points
  write (*, *) "[debug] calculating size of radial and momentum grids"

  n_r = ceiling(r_max / d_r)
  if (mod(n_r, 2) == 1) n_r = n_r + 1

  n_k = ceiling(k_max / d_k)

  ! allocate memory
  write (*, *) "[debug] allocating memory"

  allocate(r_grid(n_r))
  allocate(r_weights(n_r))

  allocate(k_grid(n_k))

  allocate(wf(n_r, n_b))
  allocate(energies(n_b))

  allocate(V_direct(n_k, n_k))
  allocate(V_exchange(n_k, n_k))

  allocate(on_direct(n_k, 2))
  allocate(on_exchange(n_k, 2))

  ! setup radial grid and weights
  write (*, *) "[debug] setting up radial grid and weights"

  do i_r = 1, n_r
    r_grid(i_r) = d_r * i_r
  end do

  r_weights(1:n_r:2) = 4.0d0 * (d_r / 3.0d0)
  r_weights(2:n_r:2) = 2.0d0 * (d_r / 3.0d0)

  ! setup momentum grid
  write (*, *) "[debug] setting up momentum grid"

  do i_k = 1, n_k
    k_grid(i_k) = d_k * i_k
  end do

  ! calculate hydrogen wavefunctions and energies
  write (*, *) "[debug] calculating hydrogen wavefunctions and energies"

  call hydrogen_wf(l, alpha, n_b, n_r, r_grid, wf, energies, status)
  if (status /= 0) call exit(status)

  ! iterate through final hydrogen states (1s, 2s, 3s)
  write (*, *) "[debug] iterating through transitions"

  i_i = 1
  do i_f = 1, 3
    write (*, "(a,i1,a,i1,a)") " [debug] transition ",i_i,"s -> ", i_f,"s"

    ! calculate v-matrix elements numerically
    write (*, *) "[debug] calculating direct terms"

    call direct_matrix(n_r, r_grid, r_weights, &
        (i_f == i_i), wf(:, i_i), wf(:, i_f), &
        n_k, k_grid, V_direct, status)
    if (status /= 0) call exit(status)

    write (*, *) "[debug] calculating exchange terms"

    call exchange_matrix(n_r, r_grid, r_weights, &
        energy, wf(:, i_i), wf(:, i_f), &
        n_k, k_grid, V_exchange, status)
    if (status /= 0) call exit(status)

    ! calculate analytic on-shell v-matrix elements
    write (*, *) "[debug] calculating on-shell elements"

    call on_elements(n_r, r_grid, r_weights, n_k, k_grid, n_b, wf, energies, &
        i_f, on_direct, on_exchange, status)
    if (status /= 0) call exit(status)

    ! write v-matrix elements to file
    write (*, *) "[debug] writing output"

    call write_output(n_k, k_grid, i_i, i_f, V_direct, V_exchange, &
        on_direct, on_exchange, status)
    if (status /= 0) call exit(status)
  end do

  write (*, *) "[debug] program finish"

end program main

! read_input
subroutine read_input (l, alpha, n_b, d_r, r_max, d_k, k_max, energy, status)
  implicit none

  integer , intent(out) :: l
  double precision , intent(out) :: alpha
  integer , intent(out) :: n_b
  double precision , intent(out) :: d_r
  double precision , intent(out) :: r_max
  double precision , intent(out) :: d_k
  double precision , intent(out) :: k_max
  double precision , intent(out) :: energy
  integer , intent(out) :: status
  ! local variables
  integer , parameter :: io_unit = 10
  character(len=200) :: io_file

  ! set filename
  io_file = "data/input/input.txt"

  ! open input file for reading
  open(unit=io_unit, file=trim(adjustl(io_file)), action="read", iostat=status)

  ! handle invalid open
  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(io_file)), " could not be opened"
    return
  end if

  ! read basis parameters
  read (io_unit, *) l, alpha, n_b

  ! read radial grid parameters
  read (io_unit, *) d_r, r_max

  ! read momentum grid parameters
  read (io_unit, *) d_k, k_max

  ! read scattering parameters
  read (io_unit, *) energy

  ! close input file
  close(io_unit)

end subroutine read_input

! write_output
subroutine write_output (n_k, k_grid, i_i, i_f, V_direct, V_exchange, &
    on_direct, on_exchange, status)
  implicit none

  integer , intent(in) :: n_k
  double precision , intent(in) :: k_grid(n_k)
  integer , intent(in) :: i_i
  integer , intent(in) :: i_f
  double precision , intent(in) :: V_direct(n_k, n_k)
  double precision , intent(in) :: V_exchange(n_k, n_k)
  double precision , intent(in) :: on_direct(n_k, 2)
  double precision , intent(in) :: on_exchange(n_k, 2)
  integer , intent(out) :: status
  ! local variables
  integer , parameter :: io_unit = 10
  character(len=200) :: io_file
  integer :: ii, jj

  ! write direct matrix elements
  write (io_file, "(a,i1,a,i1,a)") "data/output/",i_i,"s_",i_f,"s.dir.txt"

  open(unit=io_unit, file=trim(adjustl(io_file)), action="write", iostat=status)

  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(io_file)), " could not be opened"
    return
  end if

  write (io_unit, *) "# k_grid(ii), k_grid(jj), V_direct(ii, jj)"
  do ii = 1, n_k
    do jj = 1, n_k
      write (io_unit, *) k_grid(ii), k_grid(jj), V_direct(ii, jj)
    end do
    write (io_unit, *)
  end do

  close(io_unit)

  ! write exchange matrix elements
  write (io_file, "(a,i1,a,i1,a)") "data/output/",i_i,"s_",i_f,"s.exc.txt"

  open(unit=io_unit, file=trim(adjustl(io_file)), action="write", iostat=status)

  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(io_file)), " could not be opened"
    return
  end if

  write (io_unit, *) "# k_grid(ii), k_grid(jj), V_exchange(ii, jj)"
  do ii = 1, n_k
    do jj = 1, n_k
      write (io_unit, *) k_grid(ii), k_grid(jj), V_exchange(ii, jj)
    end do
    write (io_unit, *)
  end do

  close(io_unit)

  ! write on-shell direct
  write (io_file, "(a,i1,a,i1,a)") "data/output/",i_i,"s_",i_f,"s.dir.on.txt"

  open(unit=io_unit, file=trim(adjustl(io_file)), action="write", iostat=status)

  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(io_file)), " could not be opened"
    return
  end if

  write (io_unit, *) "# k_grid(ii), on_direct(ii, 1), on_direct(ii, 2)"
  write (io_unit, *) "#           , calculated      , analytic        "
  do ii = 1, n_k
    write (io_unit, *) k_grid(ii), on_direct(ii, 1), on_direct(ii, 2)
  end do

  close(io_unit)

  ! write on-shell exchange
  write (io_file, "(a,i1,a,i1,a)") "data/output/",i_i,"s_",i_f,"s.exc.on.txt"

  open(unit=io_unit, file=trim(adjustl(io_file)), action="write", iostat=status)

  if (status /= 0) then
    write (*, *) "[error] ", trim(adjustl(io_file)), " could not be opened"
    return
  end if

  write (io_unit, *) "# k_grid(ii), on_exchange(ii, 1), on_exchange(ii, 2)"
  write (io_unit, *) "#           , calculated        , analytic          "
  do ii = 1, n_k
    write (io_unit, *) k_grid(ii), on_exchange(ii, 1), on_exchange(ii, 2)
  end do

  close(io_unit)

end subroutine write_output

! on_elements
!
! Numerically calculated and analytic on-shell elements of the direct and
! exchange terms (for 1s -> ns transitions)
subroutine on_elements (n_r, r_grid, r_weights, n_k, k_grid, &
    n_b, wf, energies, i_f, on_direct, on_exchange, status)

  use vmatrix
  implicit none

  integer , intent(in) :: n_r
  double precision , intent(in) :: r_grid(n_r)
  double precision , intent(in) :: r_weights(n_r)
  integer , intent(in) :: n_k
  double precision , intent(in) :: k_grid(n_k)
  integer , intent(in) :: n_b
  double precision , intent(in) :: wf(n_r, n_b)
  double precision , intent(in) :: energies(n_b)
  integer , intent(in) :: i_f
  double precision , intent(out) :: on_direct(n_k, 2)
  double precision , intent(out) :: on_exchange(n_k, 2)
  integer , intent(out) :: status
  ! local variables
  double precision :: k_on, ki, energy
  double precision :: k, k2, k4, k6
  integer :: ii

  ! initialise on_*
  on_direct(:, :) = 0.0d0
  on_exchange(:, :) = 0.0d0

  ! check if arguments are valid
  if ((n_r < 1) .or. (n_k < 1) .or. (n_b < 1)) then
    status = 1
    return
  end if

  ! iterate through momentum grid
  write (*, *) "[debug] energies(i) = ", energies(1)
  write (*, *) "[debug] energies(f) = ", energies(i_f)

  do ii = 1, n_k
    ki = k_grid(ii)

    ! calculate on-shell energy
    energy = energies(1) + (0.5d0 * (ki ** 2))

    write (*, *) "[debug] ki = ", ki
    write (*, *) "[debug] energy = ", energy

    ! handle impossible transition
    if (energy < energies(i_f)) then
      write (*, *) "[debug] forbidden transition "
      write (*, *)
      cycle
    end if

    ! calculate on-shell momentum
    k_on = sqrt(2.0d0*(energy - energies(i_f)))

    write (*, *) "[debug] k_on = ", k_on

    ! calculate on-shell direct term
    call direct_matrix_element(n_r, r_grid, r_weights, &
        (i_f == 1), wf(:, 1), wf(:, i_f), ki, k_on, on_direct(ii, 1), status)
    if (status /= 0) return

    ! calculate on-shell exchange term
    call exchange_matrix_element(n_r, r_grid, r_weights, &
        energy, wf(:, 1), wf(:, i_f), ki, k_on, on_exchange(ii, 1), status)
    if (status /= 0) return

    ! analytic on-shell direct term
    ! (this was painful to write out)
    k = ki
    k2 = k**2
    k4 = k**4
    k6 = k**6
    select case (i_f)
    case (1)
      on_direct(ii, 2) = - 0.25d0 * ((k2 / (k2+1.0d0)) + log(k2+1.0d0))
      on_exchange(ii, 2) = - (k2 * (k2-3.0d0)) / ((k2+1.0d0)**3)

    case (2)
      on_direct(ii, 2) = &
          (16.0d0/81.0d0) * k * (4.0d0*k2 + 3.0d0) * sqrt(8.0d0*k2 - 6.0d0) &
          / ((4.0d0*k2 + 1.0d0)**2)
      on_exchange(ii, 2) = &
          (-16.0d0/9.0d0) * k * (16.0d0*k4 - 72.0d0*k2 + 13.0d0) &
          * sqrt(8.0d0*k2 - 6.0d0) &
          / ((4.0d0*k2 + 1.0d0)**4)

    case (3)
      on_direct(ii, 2) = &
          (9.0d0*sqrt(3.0d0)/128.0d0) * k * (135.0d0*k4 + 87.0d0*k2 - 4.0d0) &
          * sqrt(9.0d0*k2 - 8.0d0) / ((9.0d0*k2 + 1.0d0)**3)
      on_exchange(ii, 2) = &
          (-9.0d0*sqrt(3.0d0)/8.0d0) * k &
          * (1701.0d0*k6 - 8208.0d0*k4 + 2325.0d0*k2 - 70.0d0) &
          * sqrt(9.0d0*k2 - 8.0d0) / ((9.0d0*k2 + 1.0d0)**5)
    end select

    write (*, *) "[debug]"
  end do

end subroutine on_elements


      SUBROUTINE VMONDE ( RHO, COEF, K )
C
C**********************************************************************
C
C   purpose
C          solve vandermonde system v * x = e
C          with  v(i,j) = rho(j)**(i-1)/(i-1)! .
C
C**********************************************************************
C
      INTEGER K, I,IFAC,J,KM1,KMI
      DOUBLE PRECISION RHO(K), COEF(K)
C
      IF ( K .EQ. 1 )                             RETURN
      KM1 = K - 1
      DO 10 I = 1, KM1
         KMI = K - I
         DO 10 J = 1, KMI
           COEF(J) = (COEF(J+1) - COEF(J)) / (RHO(J+I) - RHO(J))
  10  CONTINUE
C
      IFAC = 1
      DO 40 I = 1, KM1
         KMI = K + 1 - I
         DO 30 J = 2, KMI
  30        COEF(J) = COEF(J) - RHO(J+I-1) * COEF(J-1)
         COEF(KMI) = DFLOAT(IFAC) * COEF(KMI)
         IFAC = IFAC * I
  40  CONTINUE
      COEF(1) = DFLOAT(IFAC) * COEF(1)
      RETURN
      END


!==============================================================================!
  subroutine Turb_Mod_Compute_F22(turb, sol, ini, phi)
!------------------------------------------------------------------------------!
!   Discretizes and solves eliptic relaxation equations for f22.               !
!------------------------------------------------------------------------------!
  implicit none
!--------------------------------[Arguments]-----------------------------------!
  type(Turb_Type)           :: turb
  type(Solver_Type), target :: sol
  integer                   :: ini
  type(Var_Type)            :: phi
!----------------------------------[Locals]------------------------------------!
  type(Field_Type),  pointer :: flow
  type(Grid_Type),   pointer :: grid
  type(Matrix_Type), pointer :: a
  real, contiguous,  pointer :: b(:)
  integer                    :: s, c, c1, c2, exec_iter
  real                       :: f_ex, f_im
  real                       :: a0, a12, a21
  real                       :: phi_x_f, phi_y_f, phi_z_f
!==============================================================================!
!                                                                              !
!   The form of equations which are solved:                                    !
!                                                                              !
!        /             /              /                                        !
!       |   df22      |   f22        |  f22hg                                  !
!       | - ---- dS + | ------ dV  = | ------- dV                              !
!       |    dy       |  Lsc^2       |  Lsc^2                                  !
!      /             /              /                                          !
!                                                                              !
!   Dimension of the system under consideration                                !
!                                                                              !
!     [A]{f22} = {b}   [kg K/s]                                                !
!                                                                              !
!   Dimensions of certain variables:                                           !
!                                                                              !
!     f22            [1/s]                                                     !
!     Lsc            [m]                                                       !
!------------------------------------------------------------------------------!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  call Solver_Mod_Alias_System (sol, a, b)

  ! Initialize matrix and right hand side
  a % val(:) = 0.0
  b      (:) = 0.0

  ! Old values (o) and older than old (oo)
  if(ini .eq. 1) then
    do c = 1, grid % n_cells
      phi % oo(c)   = phi % o(c)
      phi % o (c)   = phi % n(c)
    end do
  end if

  ! New values
  do c = 1, grid % n_cells
    phi % c(c) = 0.0
  end do

  ! Gradients
  call Field_Mod_Grad_Variable(flow, phi)

  !------------------!
  !                  !
  !     Difusion     !
  !                  !
  !------------------!

  !----------------------------!
  !   Spatial discretization   !
  !----------------------------!
  do s = 1, grid % n_faces

    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    phi_x_f = grid % fw(s) * phi % x(c1) + (1.0-grid % fw(s)) * phi % x(c2)
    phi_y_f = grid % fw(s) * phi % y(c1) + (1.0-grid % fw(s)) * phi % y(c2)
    phi_z_f = grid % fw(s) * phi % z(c1) + (1.0-grid % fw(s)) * phi % z(c2)

    ! Total (exact) diffusive flux
    f_ex = (  phi_x_f * grid % sx(s)   &
            + phi_y_f * grid % sy(s)   &
            + phi_z_f * grid % sz(s) )

    a0 = a % fc(s)

    ! Implicit diffusive flux
    f_im=(   phi_x_f * grid % dx(s)        &
           + phi_y_f * grid % dy(s)        &
           + phi_z_f * grid % dz(s)) * a0

    ! Cross diffusion part
    phi % c(c1) = phi % c(c1) + f_ex - f_im
    if(c2  > 0) then
      phi % c(c2) = phi % c(c2) - f_ex + f_im
    end if

    ! Calculate the coefficients for the sysytem matrix
    a12 = a0
    a21 = a0

    ! Fill the system matrix
    if(c2  > 0) then
      a % val(a % pos(1,s)) = a % val(a % pos(1,s)) - a12
      a % val(a % dia(c1))  = a % val(a % dia(c1))  + a12
      a % val(a % pos(2,s)) = a % val(a % pos(2,s)) - a21
      a % val(a % dia(c2))  = a % val(a % dia(c2))  + a21
    else if(c2  < 0) then

      ! Inflow
      if( (Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. INFLOW)) then
        a % val(a % dia(c1)) = a % val(a % dia(c1)) + a12
        b(c1) = b(c1) + a12 * phi % n(c2)
      end if

      ! Wall and wall flux; solid walls in any case
      if( (Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL).or.       &
          (Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) ) then
        a % val(a % dia(c1)) = a % val(a % dia(c1)) + a12
        !---------------------------------------------------------------!
        !   Source coefficient is filled in SourceF22.f90 in order to   !
        !   get updated values of f22 on the wall.  Otherwise f22       !
        !   equation does not converge very well                        !
        !   b(c1) = b(c1) + a12 * phi % n(c2)                           !
        !---------------------------------------------------------------!
      end if
    end if

  end do  ! through faces

  ! Cross diffusion terms are treated explicity
  do c = 1, grid % n_cells
    b(c) = b(c) + phi % c(c)
  end do

  !-------------------------------------!
  !                                     !
  !   Source terms and wall function    !
  !                                     !
  !-------------------------------------!
  if(turb % model .eq. RSM_MANCEAU_HANJALIC) then
    call Turb_Mod_Src_F22_Rsm_Manceau_Hanjalic(turb, sol)
  else
    call Turb_Mod_Src_F22_K_Eps_Zeta_F(turb, sol)
  end if

  !---------------------------------!
  !                                 !
  !   Solve the equations for phi   !
  !                                 !
  !---------------------------------!

  ! Underrelax the equations
  call Numerics_Mod_Under_Relax(phi, sol)

  ! Call linear solver to solve the equations
  call Cg(sol,            &
          phi % n,        &
          b,              &
          phi % precond,  &
          phi % niter,    &
          exec_iter,      &
          phi % tol,      &
          phi % res)

  ! Print info on the screen
  if(turb % model .eq. K_EPS_ZETA_F) then
    call Info_Mod_Iter_Fill_At(3, 4, phi % name, exec_iter, phi % res)
  else if(turb % model .eq. RSM_MANCEAU_HANJALIC) then
    call Info_Mod_Iter_Fill_At(4, 2, phi % name, exec_iter, phi % res)
  end if

  call Grid_Mod_Exchange_Cells_Real(grid, phi % n)

  end subroutine


module parameters
    use numbers
    use openmpi
    use io

    ! DO NOT EDIT ABOVE THIS LINE
    character(7), parameter :: revision = "e5b0c85"

    !# Geometry & discretization
    integer(i4) :: &
        nx = 48, ny = 48, nz = 48, & ! number of grid points
        nxx, nyy, nzz, & ! number of super-sampled grid points
        nx_half, ny_half, nz_half, & ! shorthands
        nyy_half_pad1, & ! nyy/2+1 are frequently used in r2c
                                 ! transforms see "2.3 One-Dimensional DFTs of
                                 ! Real Data" / fftw3 manual
        nx_perproc, nzz_perproc

    integer(i4), parameter :: supsamp_fac = 3 ! supsamp_fac / 2 dealiasing

    real(dp)            :: Lx = 4.0_dp, Lz = 4.0_dp ! grid dimensions
    real(dp), parameter :: Ly = 4.0_dp ! fixed by non-dimensionalization

    !# Physics
    integer(i4) :: forcing = 1 ! none = 0, sine = 1, cosine = 2
    integer(i4), parameter :: qF = 1 ! Forcing wave number
    real(dp) :: Re = 630.0_dp, &  ! Reynolds number
                tilt_angle = 0, & ! (degrees) tilting angle
                smag_const = 0, & ! Smagorinsky constant for LES
                Delta_LES = 0
    logical :: LES = .false. , tilting = .false.

    !# Initiation
    integer(i4) :: IC = -1, &     ! Initial condition
                               ! (-3 shapiro, -2 laminar, -1 random,
                               !   0 state.{istart / i_save_fields)
                   i_start = 0 ! Starting time step
    integer(i8) :: random_seed = -1 ! -1 reads from /dev/urandom
    real(dp) :: random_energy = 0.1_dp, & ! (ekin_laminar) energy of the random IC
                random_smooth = 0.9_dp, & ! smoothness factor for random IC
                t_start = 0 ! Starting time

    !# Results -- note i_* convention for variables in time step units
    integer(i4) :: i_print_stats = 20, &   ! Print energy, dissipation etc.
                   i_print_steps = 20, &   ! Print Courant, step error etc.
                   i_save_fields = 2000, & ! Save fields (restart files)
                   i_save_sliced_fields = -1, & ! Save symmetry reduced fields
                   i_print_spectrum = -1, &
                   i_flush = -1, &
                   i_project = -1

    !# Time stepping
    real(dp)    :: dt = 0.025_dp, &
                   implicitness = 0.5_dp, &
                   steptol = 1.0e-9_dp, &
                   dtmax = 0.1_dp, &
                   courant_target = 0.25_dp
    integer(i4) :: ncorr = 10
    logical :: adaptive_dt = .true., &
               integrate_invariant = .false. ! if true, use converged time
                                             ! step of an invariant solution.

    !# Termination
    logical  :: terminate_laminar = .true. ! terminate on laminarization
    real(dp) :: relerr_lam = 0.1_dp ! conclude laminarization if stats within
                                    ! relerr_lam of those of laminar
    real(sp) :: wall_clock_limit = -1.0_sp
    integer(i4) :: i_finish = -1 ! time step limit

    !# Diagnostics
    logical :: log_divergence  = .false.
    real(dp) :: divergence_th = 1.0e-16_dp, &
                shapiro_alpha, shapiro_beta, shapiro_gamma, shapiro_lambda
    integer(i4) :: shapiro_qalpha = 1, shapiro_qbeta = 1, shapiro_qgamma = 1

    ! symmetries
    logical :: Rxy = .false., Ry = .false., Rz = .false., Sx = .false., &
               Sy = .false., &
               slice = .false.

    ! Projections
    integer(i4) :: num_proj_bases = 10
    logical :: subtract_origin = .false.

    ! Lyapunov exponent
    logical :: compute_lyap = .false.
    logical :: lyap_normalize = .true.
    integer(i4) :: i_lyap
    real(dp) :: eps_lyap, trans_lyap, k_cutoff

    integer(i4) :: itime ! simulation timestep count
    real(dp)    :: time, &  ! simulation time
                   dx, dy, dz, &! grid spacings in the expanded physical space
                   norm_fft, &! fft forward+backward needs to be normalized
                   kF ! forcing wave number

    ! laminar values
    real(dp) :: ekin_lam, powerin_lam, dissip_lam

    ! Given 3x3 symmetric matrix M, entries M_{ij} will be used
    integer(i4), parameter, dimension(6) :: isym = (/1, 1, 1, 2, 2, 3/), &
                                            jsym = (/1, 2, 3, 2, 3, 3/)
    integer(i4) :: nsym(3,3)

    namelist /grid/ nx, ny, nz, Lx, Lz
    namelist /physics/ forcing, Re, tilt_angle, smag_const
    namelist /initiation/ IC, random_seed, random_energy, random_smooth, &
                          t_start, i_start
    namelist /output/ i_print_stats, i_print_steps, i_save_fields, &
                      i_print_spectrum, i_flush, i_project, i_save_sliced_fields
    namelist /time_stepping/ dt, implicitness, steptol, ncorr, adaptive_dt, &
                             dtmax, courant_target, integrate_invariant
    namelist /termination/ terminate_laminar, relerr_lam, wall_clock_limit, i_finish
    namelist /debugging/ log_divergence, divergence_th, shapiro_qalpha, shapiro_qbeta, shapiro_qgamma
    namelist /symmetries/ Rxy, Ry, Rz, Sx, Sy, slice
    namelist /lyapunov/ compute_lyap, lyap_normalize, i_lyap, eps_lyap, trans_lyap, k_cutoff
    namelist /projection/ num_proj_bases, subtract_origin

    contains

!==============================================================================

    subroutine parameters_init

        integer(i4) :: in, i, j, n

        do n = 1,6
            i = isym(n)
            j = jsym(n)
            nsym(i,j) = n
            nsym(j,i) = n
        end do

        ! Is parameters.in here?
        inquire(file = 'parameters.in', exist=there)
        if(.not.there) then
            write(out,*) 'cannot find parameters.in'
            flush(out)
            error stop
        end if

        ! Read parameters from the input file
        open(newunit=in, file='parameters.in', status="old")
        read(in, nml=grid)
        read(in, nml=physics)
        read(in, nml=symmetries)
        read(in, nml=initiation)
        read(in, nml=output)
        read(in, nml=time_stepping)
        read(in, nml=termination)
        read(in, nml=debugging)
        read(in, nml=lyapunov)
        if (i_project > 0) read(in, nml=projection)
        close(in)

        write(out, *) 'dnsbox revision: ', revision
        write(out, *) 'num_procs: ', num_procs
        write(out, *) 'forcing = ', forcing
        write(out, *) 'epsilon = ', epsilon
        write(out, *) 'small = ', small

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, "('nx, ny, nz', 3i4)") nx, ny, nz
        write(out, *) 'Lx = ', Lx
        write(out, *) 'Ly = ', Ly
        write(out, *) 'Lz = ', Lz

        if (mod(nx, 2) /= 0 .or. mod(ny, 2) /= 0 .or. mod(nz, 2) /= 0) then
            write(out, *) 'nx, ny and nz must be even'
            flush(out)
            error stop
        end if

        nx_perproc = nx / num_procs
        nx_half = nx / 2
        ny_half = ny / 2
        nz_half = nz / 2

        if (nx_perproc * num_procs /= nx) then
            write(out, *) '*** wrong nx:', nx, &
                          '*** should be divisible by num_procs:', num_procs
            flush(out)
            error stop
        end if

        ! compute the size of the supersampled grid
        nxx = supsamp_fac * nx_half
        nyy = supsamp_fac * ny_half
        nzz = supsamp_fac * nz_half

        nyy_half_pad1 = nyy / 2 + 1

        nzz_perproc  = nzz / num_procs

        ! Pad z in the physical dimension if necessary to make it divisible
        ! by num_procs
        if (nzz_perproc * num_procs /= nzz) then
            nzz_perproc = nzz_perproc + 1
            nzz = nzz_perproc * num_procs

        end if

        if (nx - 1 >= ny_half .and. nx - 1 >= nz - 1) then
            write(out, *) "using x-compact saves."
        elseif (ny_half >= nx - 1 .and. ny_half >= nz - 1) then
            write(out, *) "using y-compact saves."
        else
            write(out, *) "using z-compact saves."
        end if

        ! Not sure what happens to the transpose algorithm if in either
        ! wavenumber or physical space we end up with just one mode in the
        ! distributed dimension
        if (nx_perproc <= 1 .or. nzz_perproc <= 1) then
            write(out, *) '*** num_procs too large:', num_procs, &
                          '*** nx_perproc:', nx_perproc, &
                          '*** nzz_perproc:', nzz_perproc
            flush(out)
            error stop
        end if

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, "('nxx, nyy, nzz', 3i4)") nxx, nyy, nzz

        norm_fft = 1.0_dp / (nxx * nyy * nzz)

        dx = Lx / nxx
        dy = Ly / nyy
        dz = Lz / nzz

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, *) 'Re = ', Re

        if (abs(tilt_angle) > small) then
            write(out, *) 'tilt_angle = ', tilt_angle
            tilting = .true.
        end if

        if (smag_const > small) then
            write(out, *) 'smag_const = ', smag_const
            LES       = .true.
            Delta_LES = Lx / nx
        end if

        if (LES .and. &
            ((.not. are_equal(dx, dy)) .or. (.not. are_equal(dx, dz)) &
             .or. (.not. are_equal(dy, dz)))) then
            write(out, *) 'Warning: LES simulation with a nonequal grid'
        end if

        ! Set the forcing wavenumber
        kF = 2.0_dp * PI * qF / Ly

        ! compute laminar values
        ekin_lam    = 1.0_dp / 4.0_dp
        powerin_lam = PI**2 / (8 * Re)
        dissip_lam  = powerin_lam

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, *) 'Rxy = ', Rxy
        write(out, *) 'Ry = ', Ry
        write(out, *) 'Rz = ', Rz
        write(out, *) 'Sx = ', Sx
        write(out, *) 'Sy = ', Sy
        write(out, *) 'slice = ', slice
        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        if (integrate_invariant) then
            IC = 0
            adaptive_dt = .false.
            write(out, *) 'integrate_invariant = ', integrate_invariant
        end if

        write(out, *) 'IC = ', IC
        write(out, *) 'random_seed = ', random_seed
        write(out, *) 'random_energy = ', random_energy
        write(out, *) 'random_smooth = ', random_smooth

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, *) 't_start = ', t_start
        write(out, *) 'i_start = ', i_start
        write(out, *) 'i_print_stats = ', i_print_stats
        write(out, *) 'i_print_steps = ', i_print_steps
        write(out, *) 'i_save_fields = ', i_save_fields
        write(out, *) 'i_save_sliced_fields = ', i_save_sliced_fields
        write(out, *) 'i_print_spectrum = ', i_print_spectrum
        write(out, *) 'i_flush = ', i_flush
        write(out, *) 'i_project = ', i_project

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, *) 'dt = ', dt
        write(out, *) 'implicitness = ', implicitness
        write(out, *) 'steptol = ', steptol
        write(out, *) 'ncorr = ', ncorr
        write(out, *) 'adaptive_dt = ', adaptive_dt
        write(out, *) 'dtmax = ', dtmax
        write(out, *) 'courant_target = ', courant_target

        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        write(out, *) 'terminate_laminar = ', terminate_laminar
        write(out, *) 'relerr_lam = ', relerr_lam
        write(out, *) 'wall_clock_limit = ', wall_clock_limit
        write(out, *) 'i_finish = ', i_finish

        write(out, '(79(''=''))')

       ! ---------------------------------------------------------------------

        write(out, *) 'log_divergence = ', log_divergence
        write(out, *) 'divergence_th = ', divergence_th

        if (IC == -3) then
            shapiro_alpha = (2.0_dp * PI / Lx)  * shapiro_qalpha
            shapiro_beta = (2.0_dp * PI / Ly)  * shapiro_qbeta
            shapiro_gamma = (2.0_dp * PI / Lz)  * shapiro_qgamma
            shapiro_lambda = sqrt(shapiro_alpha**2 + shapiro_beta**2 + &
                                                            shapiro_gamma**2)

            write(out, *) "shapiro_qalpha = ", shapiro_qalpha
            write(out, *) "shapiro_qbeta = ", shapiro_qbeta
            write(out, *) "shapiro_qgamma = ", shapiro_qgamma
            write(out, *) "shapiro_alpha = ", shapiro_alpha
            write(out, *) "shapiro_beta = ", shapiro_beta
            write(out, *) "shapiro_gamma = ", shapiro_gamma
            write(out, *) "shapiro_lambda = ", shapiro_lambda
        end if
        write(out, '(79(''=''))')

        ! ---------------------------------------------------------------------

        if (compute_lyap) then

            write(out, *) 'i_lyap = ', i_lyap
            write(out, *) 'eps_lyap = ', eps_lyap
            write(out, *) 'trans_lyap = ', trans_lyap
            write(out, *) 'k_cutoff = ', k_cutoff

        end if

        write(out, '(79(''=''))')

    end subroutine parameters_init

!==============================================================================

end module parameters


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_beta_dist
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_gamma_dist
  Use mlf_poly
  Use mlf_distribution
  Use mlf_2dplane_integration
  IMPLICIT NONE
  PRIVATE

  Public :: LogBetaFunction, BetaFunction, RandomBeta
  Public :: BetaDensity, IncompleteBeta, IntegrateIncompleteBeta
  Public :: QuantileTableBeta, QuantileBeta
  Public :: MaxLikelihoodBeta, MaxLikelihoodBetaPriorBeta
  Public :: BetaPriorConst, BetaPriorMaxLL

  real(c_double), parameter :: m_gamma = 0.5772156649015328606d0 ! Euler-Maschenori constant

  Type, Public, Extends(mlf_distributionWithQuantile_type) :: mlf_beta_distribution
    real(c_double) :: alpha, beta, a = 0d0, b = 1d0
  Contains
    procedure :: getParameters => Beta_getParameters
    procedure :: withParameters => Beta_withParameters
    procedure :: getStats => Beta_getStats
    procedure :: fitWithData => Beta_fitWithData
    procedure :: quantile => Beta_quantile
    procedure :: quantileTable => Beta_quantileTable
    procedure :: computeCDF => Beta_computeCDF
    procedure :: computePDF => Beta_computePDF
    procedure :: computeLogPDF => Beta_computeLogPDF
  End Type mlf_beta_distribution

  Type, Public, Extends(mlf_distribution_multivariate) :: mlf_beta_prior
    real(c_double) :: lambda, x0, y0
  Contains
    procedure :: getParameters => Beta_Prior_getParameters
    procedure :: withParameters => Beta_Prior_withParameters
    procedure :: fitWithData => Beta_Prior_fitWithData
    procedure :: computePDF => Beta_Prior_computePDF
    procedure :: computeLogPDF => Beta_Prior_computeLogPDF
  End Type mlf_beta_prior

  Type, Extends(mlf_2dplane_h_fun) :: Beta_prior_integrate
    real(c_double) :: lambda, x0, y0
  Contains
    procedure :: getValDer => Beta_prior_getValDer
  End Type Beta_prior_integrate
Contains
  Integer Function Beta_getParameters(this, X) Result(info)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    info = 0
    Select Case(SIZE(X))
    Case(2)
      X = [this%alpha, this%beta]
    Case(4)
      X = [this%alpha, this%beta, this%a, this%b]
    Case Default
      info = -1
    End Select
  End Function Beta_getParameters

  Integer Function Beta_withParameters(this, X) Result(info)
    class(mlf_beta_distribution), intent(inout) :: this
    real(c_double), intent(in) :: X(:)
    info = 0
    Select Case(SIZE(X))
    Case(2)
      this%alpha = X(1); this%beta = X(2)
      this%a = 0; this%b = 1
    Case(4)
      this%alpha = X(1); this%beta = X(2)
      this%a = X(3); this%b = X(4)
    Case Default
      info = -1
    End Select
  End Function Beta_withParameters

  Real(c_double) Function Beta_getStats(this, statType) Result(y)
    class(mlf_beta_distribution), intent(in) :: this
    integer, intent(in) :: statType
    ASSOCIATE(a => this%a, b => this%b, alpha => this%alpha, beta => this%beta)
      Select Case(statType)
      Case (mlf_dist_mode)
        y = a + (b-a)*(alpha - 1d0)/(alpha + beta - 2d0)
      Case (mlf_dist_median)
        y = this%quantile(0.5d0)
      Case (mlf_dist_mean)
        y = a + (b-a)*alpha/(alpha+beta)
      Case (mlf_dist_geom_mean)
        y = Digamma(alpha)-Digamma(alpha+beta)
      Case Default
        y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      End Select
    END ASSOCIATE
  End Function Beta_getStats

  Integer Function Beta_fitWithData(this, Points, W, prior) Result(info)
    class(mlf_beta_distribution), intent(inout) :: this
    real(c_double), intent(in) :: Points(:)
    real(c_double), intent(in), optional :: W(:)
    class(mlf_distribution_abstract), optional, intent(in) :: prior
    If(PRESENT(prior)) Then
      Select Type(prior)
      Class is (mlf_beta_distribution)
        info = MaxLikelihoodBetaPriorBeta(Points, this%alpha, this%beta, &
          prior%alpha, prior%beta, this%a, this%b)
      Class Default
        info = -1
      End Select
    Else
      info = MaxLikelihoodBeta(Points, this%alpha, this%beta, W, this%a, this%b)
    Endif
  End Function Beta_fitWithData

  Subroutine Beta_quantileTable(this, X)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    CALL QuantileTableBeta(this%alpha, this%beta, X)
    X = this%a + (this%b-this%a)*X
  End Subroutine Beta_quantileTable

  Real(c_double) Function Beta_quantile(this, y) Result(x)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(in) :: y
    x = this%a + (this%b-this%a)*QuantileBeta(this%alpha, this%beta, y)
  End Function Beta_quantile

  Real(c_double) Function Beta_computeCDF(this, x) Result(y)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(in) :: x
    If(x <= this%a) Then
      y = 0
    Else If(x >= this%b) Then
      y = 1
    Else
      y = IncompleteBeta(this%alpha, this%beta, (x-this%a)/(this%b-this%a))
    Endif
  End Function Beta_computeCDF

  Elemental Real(c_double) Function Beta_computePDF(this, x) Result(y)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(in) :: x
    If(x >= this%a .AND. x <= this%b) Then
      y = BetaDensity(this%alpha, this%beta, (x-this%a)/(this%b-this%a))/(this%b-this%a)
    Else
      y = 0
    Endif
  End Function Beta_computePDF

  Elemental Real(c_double) Function Beta_computeLogPDF(this, x) Result(y)
    class(mlf_beta_distribution), intent(in) :: this
    real(c_double), intent(in) :: x
    If(x >= this%a .AND. x <= this%b) Then
      y = LogBetaDensity(this%alpha, this%beta, (x-this%a)/(this%b-this%a))-LOG(this%b-this%a)
    Else
      y = -HUGE(1d0)
    Endif
  End Function Beta_computeLogPDF

  Integer Function Beta_Prior_getParameters(this, X) Result(info)
    class(mlf_beta_prior), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    X = [this%lambda, this%x0, this%y0]
    info = 0
  End Function Beta_Prior_getParameters

  Integer Function Beta_Prior_withParameters(this, X) Result(info)
    class(mlf_beta_prior), intent(inout) :: this
    real(c_double), intent(in) :: X(:)
    this%lambda = X(1)
    this%x0     = X(2)
    this%y0     = X(3)
    info = 0
  End Function Beta_Prior_withParameters

  Real(c_double) Function Beta_Prior_computeLogPDF(this, X) Result(y)
    class(mlf_beta_prior), intent(in) :: this
    real(c_double), intent(in) :: X(:)
    ASSOCIATE(x0 => this%x0, y0 => this%y0, lambda => this%lambda, &
        alpha => X(1), beta => X(2))
      y = lambda*(LOG_GAMMA(alpha+beta) - LOG_GAMMA(alpha) - LOG_GAMMA(beta)) &
        + alpha*LOG(x0) + beta*LOG(y0)
    END ASSOCIATE
  End Function Beta_Prior_computeLogPDF

  Real(c_double) Function Beta_Prior_computePDF(this, X) Result(y)
    class(mlf_beta_prior), intent(in) :: this
    real(c_double), intent(in) :: X(:)
    y = EXP(this%computeLogPDF(X))
  End Function Beta_Prior_computePDF

  Integer Function Beta_Prior_fitWithData(this, Points, W, prior) Result(info)
    class(mlf_beta_prior), intent(inout) :: this
    real(c_double), intent(in) :: Points(:,:)
    real(c_double), intent(in), optional :: W(:)
    class(mlf_distribution_abstract), optional, intent(in) :: prior
    real(c_double) :: sLG, sAlpha, sBeta
    info = -1
    sLG = 0; sAlpha = 0; sBeta = 0
    If(PRESENT(W)) Then
      sLG = SUM(W*(LOG_GAMMA(Points(1,:) + Points(2,:)) &
                - LOG_GAMMA(Points(1,:)) - LOG_GAMMA(Points(2,:))))
      sAlpha = SUM(W*Points(1,:))
      sBeta = SUM(W*Points(2,:))
    Else
      sLG = SUM(LOG_GAMMA(Points(1,:) + Points(2,:)) &
                - LOG_GAMMA(Points(1,:)) - LOG_GAMMA(Points(2,:)))
      sAlpha = SUM(Points(1,:))
      sBeta = SUM(Points(2,:))
    Endif
  End Function Beta_Prior_fitWithData

  Pure Subroutine BetaPriorMaxLL(lambda, x0, y0, alpha, beta)
    real(c_double), intent(in) :: lambda, x0, y0
    real(c_double), intent(out) :: alpha, beta
    real(c_double) :: lX0, lY0, Fa
    real(c_double) :: X(2), F(2), H(3), Tr(3), invDetH
    integer :: i
    integer, parameter :: nMax = 50
    If(lambda <= 0) Then
      alpha = 0d0; beta = 0d0
      RETURN
    Endif
    alpha = IEEE_VALUE(alpha, IEEE_QUIET_NAN)
    beta  = IEEE_VALUE(beta,  IEEE_QUIET_NAN)
    ! We try to find the maximum likelihood of the distribution
    ! A(alpha, beta) ~ Beta(alpha, beta)^-lambda * x0^alpha * y0^beta

    lX0 = LOG(x0); lY0 = LOG(y0)

    ! Does not converge in this case: this function can go to infinity
    If(EXP(lX0/lambda) + EXP(lY0/lambda) >= 1) RETURN

    ! The maximum likelihood is found using a Newton's method
    ! We use the derivatives of this function A
    ! dA/dalpha(alpha,beta) = A(alpha,beta)*f1(alpha,beta)
    ! dA/dbeta(alpha,beta)  = A(alpha,beta)*f2(alpha,beta)
    ! with f1 and f2 defined as:
    ! f1(alpha, beta) = LOG(x0) - lambda*(Digamma(alpha) - Digamma(alpha+beta))
    ! f2(alpha, beta) = LOG(y0) - lambda*(Digamma(beta)  - Digamma(alpha+beta))

    ! Find a first approximation of alpha and beta:
    ! Using f1 = 0 = f2 we have Digamma(alpha)-Digamma(beta) = (log(x0)-log(y0))/lambda
    ! We use the approximation Digamma(alpha)-Digamma(beta) ~= log(alpha)-log(beta)
    ! => beta ~= alpha*U with U = (y0/x0)^1/lambda
    ! We try to find the root of the function
    ! u(alpha) = Digamma(alpha*(1+U))-1/2*(Digamma(alpha)+Digamma(alpha*U))+log(x0*y0)/2/lambda
    If(x0 < y0) Then
      Fa = EXP((lY0-lX0)/lambda)
      X(2) = EstimateRoot(Fa, lX0/lambda)
      X(1) = X(2)/Fa
    Else
      Fa = EXP((lX0-lY0)/lambda)
      X(1) = EstimateRoot(Fa, lY0/lambda)
      X(2) = X(1)/Fa
    Endif

    If(ANY(IEEE_IS_NAN(X))) X = [1d0, 1d0]
    ! Apply Newton's method on log likelihood for finding the roots
    Do i = 1, nMax
      F = lambda*(Digamma(X(1)+X(2)) - Digamma(X)) + [lX0, lY0]
      If(SUM(F*F) < MAX(1d-25, -1d-20*lambda*(lX0+lY0))) EXIT
      Tr = Trigamma([X(1), X(2), X(1)+X(2)])
      H = lambda*(Tr(3) - [Tr(1), Tr(2), 0d0])
      invDetH = 1d0/(H(1)*H(2)-H(3)**2)
      X = MAX(X - invDetH*[H(2)*F(1)-H(3)*F(2), -H(3)*F(1)+H(1)*F(2)], 0.25d0*X)
    End Do
    alpha = X(1)
    beta  = X(2)
  Contains
    Pure Real(c_double) Function UA(z, U)
      real(c_double), intent(in) :: z, U
      UA = Digamma(z*(1d0+U)) - Digamma(z)
    End Function UA

    Pure Real(c_double) Function DUA(z, U)
      real(c_double), intent(in) :: z, U
      DUA = (1d0+U)*Trigamma(z*(1d0+U)) - Trigamma(z)
    End Function DUA

    Pure Real(c_double) Function EstimateRoot(U, V) Result(z)
      real(c_double), intent(in) :: U, V
      real(c_double) :: z0, z1, a0, a1, a, da
      integer :: i
      integer, parameter :: nMax = 30
      z = IEEE_VALUE(z, IEEE_QUIET_NAN)
      a = UA(1d0, U) + V
      da = DUA(1d0, U)
      If(a*da > 0d0) Then
        z0 = 0.5d0; z1 = 1d0
        a0 = UA(z0, U) + V; a1 = a
        Do While(a0*a1 > 0d0)
          z1 = z0
          a1 = a0
          z0 = 0.5d0*z0
          a0 = UA(z0, U) + V
        End Do
      Else
        z0 = 1d0; z1 = 2d0
        a0 = a; a1 = UA(z1, U) + V
        Do While(a0*a1 > 0d0)
          z0 = z1
          a0 = a1
          z1 = 2d0*z1
          a1 = UA(z1, U) + V
          If(ABS(a1-a0)/z1 < 1d-20) RETURN
        End Do
      Endif
      z = z0+(z1-z0)*a0/(a0-a1)
      a = UA(z, U) + V
      Do i= 1, nMax
        If(ABS(a) < 1d-6) RETURN
        If(a*a0 > 0) Then
          a0 = a; z0 = z
        Else
          a1 = a; z1 = z
        Endif
        da = DUA(z, U)
        z = z - a/da
        If(da == 0 .OR. z < z0 .OR. z > z1) z = z0+(z1-z0)*a0/(a0-a1)
        a = UA(z, U) + V
      End Do
    End Function EstimateRoot
  End Subroutine BetaPriorMaxLL

  Subroutine Beta_prior_getValDer(this, x, y, D)
    class(Beta_prior_integrate), intent(inout) :: this
    real(c_double), intent(in) :: x, y
    type(mlf_2d_h_val), intent(out) :: D
    real(c_double) :: Dg(3), Tg(3), Ga, Gb, F
    ASSOCIATE(z => x+y, lambda => this%lambda, lX0 => LOG(this%x0), lY0 => LOG(this%y0))
      F = EXP(lambda*(LOG_GAMMA(z)-LOG_GAMMA(x)-LOG_GAMMA(y)) + lX0*x + lY0*y)
      Dg = Digamma([x, y, z])
      Tg = Trigamma([x, y, z])
      Ga = lambda*(Dg(3)-Dg(1)) + lX0
      Gb = lambda*(Dg(3)-Dg(2)) + lY0
      D%val = F
      D%der = F*[Ga, Gb]
      D%hes(1) = F*(Ga**2 + lambda*(Tg(3)-Tg(1)))
      D%hes(2) = F*(Gb**2 + lambda*(Tg(3)-Tg(2)))
      D%hes(3) = F*(Ga*Gb + lambda*Tg(3))
    END ASSOCIATE
  End Subroutine Beta_prior_getValDer

  Real(c_double) Function BetaPriorGetBorders(lambda, x0, y0, dx, b, N) Result(y)
    real(c_double), intent(in) :: lambda, x0, y0, dx, b
    integer, intent(in) :: N
    real(c_double) :: lY0, S, u, y0b, F, dxL
    integer :: i
    lY0 = LOG(y0)
    y0b = EXP(lY0*b)
    F = y0b/REAL(N+1,8)
    S = 0
    Do i = 1, N
      u = F*REAL(i)
      S = S + LOG_GAMMA(2*LOG(u)/lY0)*u
    End Do
    S = 2*S + LOG_GAMMA(b)*EXP(0.5d0*lY0*b)
    dxL = dx**(lambda+1d0)
    y = -y0b/lY0*dxL*(1d0/(lambda+1)+dx/(lambda+2)*(lambda*m_gamma+LOG(x0))) &
      + lambda/(lambda+2)*dxL*dx*(S-y0b*LOG_GAMMA(b))
  End Function BetaPriorGetBorders

  Real(c_double) Function BetaPriorConst2(lambda, x0, y0, eps, N, aMax, bMax) Result(y)
    real(c_double), intent(in) :: lambda, x0, y0, eps
    real(c_double), intent(in), optional :: aMax, bMax
    integer, intent(in) :: N
    real(c_double) :: alpha0, beta0, rN, rNij, invM, invM2, maxL, lX0, lY0
    real(c_double) :: dx, dy
    type(Beta_prior_integrate) :: fun
    If(PRESENT(aMax) .AND. PRESENT(bMax)) Then
      alpha0 = aMax; beta0 = bMax
    Else
      CALL BetaPriorMaxLL(lambda, x0, y0, alpha0, beta0)
    Endif
    fun%lambda = lambda; fun%x0 = x0; fun%y0 = y0
    dx = 1d-3*eps**(1d0/lambda); dy = dx
    y = BetaPriorGetBorders(lambda, x0, y0, dx, dy, N) &
      + BetaPriorGetBorders(lambda, y0, x0, dy, dx, N)
    y = y + fun%integrateOnPlane(eps, 20, x0 = x0, y0 = y0, xMin = dx, yMin = dy)
  End Function BetaPriorConst2

  Elemental Real(c_double) Function BetaPriorConst(lambda, x0, y0, N, aMax, bMax) Result(y)
    real(c_double), intent(in) :: lambda, x0, y0
    real(c_double), intent(in), optional :: aMax, bMax
    integer, intent(in) :: N
    real(c_double) :: alpha0, beta0, rN, rNij, invM, invM2, maxL, lX0, lY0
    real(c_double) :: S, Sa, alpha, beta, lGa, a, va, vb
    integer :: Nk, Nl, i, j, k, l, M
    If(PRESENT(aMax) .AND. PRESENT(bMax)) Then
      alpha0 = aMax; beta0 = bMax
    Else
      CALL BetaPriorMaxLL(lambda, x0, y0, alpha0, beta0)
    Endif
    Nk = CEILING(alpha0); Nl = CEILING(beta0)
    rN = REAL(N,8)
    M = MAX(CEILING(rN/(REAL(Nk,8)*REAL(Nl,8))), 8)
    invM = 1d0/REAL(M,8)
    invM2 = invM**2
    lX0 = LOG(x0); lY0 = LOG(y0)
    maxL = EXP(lambda*(LOG_GAMMA(alpha0+beta0)-LOG_GAMMA(alpha0)-LOG_GAMMA(beta0)) &
              + alpha0*lX0 + beta0*lY0)
    y = 0
    Do i = 1, M
      alpha = REAL(i,8)*invM
      lGa = LOG_GAMMA(alpha)
      S = 0
      Do j = 1, M
        beta = REAL(j,8)*invM
        a = EXP(lambda*(LOG_GAMMA(alpha+beta)-lGa-LOG_GAMMA(beta)) + alpha*lX0 + beta*lY0)
        Sa = 0
        va = a
        Do k = 1, MAX(Nk*4, Nk+20)
          vb = va
          Do l = 1, MAX(Nl*4, Nl+20)
            Sa = Sa + vb
            vb = vb*((alpha+beta+k+l)/(beta+l))**lambda*y0
            If(l > Nl .AND. vb < 1d-8*maxL) Then
              Sa = Sa + vb; EXIT
            Endif
          End Do
          va = va*((alpha+beta+k)/(alpha+k))**lambda*x0
          If(k > Nk .AND. va < 1d-8*maxL) EXIT
        End Do
        S = S + Sa
      End Do
      y = y + S*invM2
    End Do
  End Function BetaPriorConst

  Real(c_double) Function RandomBeta(a, b) Result(y)
    real(c_double), intent(in) :: a, b
    real(c_double) :: R(2), X(2), S
    If(a <= 1d0 .AND. b <= 1d0) Then
      ! Johnk's algorithm
      S = HUGE(0d0)
      Do While(S > 1d0)
        CALL RANDOM_NUMBER(R)
        X = R**(1d0/[a, b])
        S = SUM(X)
      End Do
      If(S > 0) Then
        y = X(1)/S
      Else
        X = LOG(R)/[a,b]
        X = X - MAXVAL(X)
        S = SUM(EXP(X))
        y = EXP(X(1) - LOG(S))
      Endif
    Else
      ! Use gamma distribution sampling
      R(1) = RandomGamma(a)
      R(2) = RandomGamma(b)
      y = R(1)/SUM(R)
    Endif
  End Function RandomBeta

  Elemental Real(c_double) Function BetaDensity(a, b, x) Result(y)
    real(c_double), intent(in) :: a, b, x
    y = x**(a-1)*(1-x)**(b-1)/BetaFunction(a,b)
  End Function BetaDensity

  Elemental Real(c_double) Function LogBetaDensity(a, b, x) Result(y)
    real(c_double), intent(in) :: a, b, x
    y = LOG(x)*(a-1)+LOG(1-x)*(b-1)-LogBetaFunction(a,b)
  End Function LogBetaDensity

  Elemental Real(c_double) Function LogBetaFunction(a, b) Result(y)
    real(c_double), intent(in) :: a, b
    y = LOG_GAMMA(a)+LOG_GAMMA(b)-LOG_GAMMA(a+b)
  End Function LogBetaFunction

  Elemental Real(c_double) Function BetaFunction(a, b) Result(y)
    real(c_double), intent(in) :: a, b
    y = EXP(LogBetaFunction(a, b))
  End Function BetaFunction

  Real(c_double) Function QuantileBeta(a, b, y) Result(x)
    real(c_double), intent(in) :: a, b, y
    real(c_double) :: F, dx, V, xMin, xMax, vMin, vMax, dMin, dMax, d0, d1
    integer, parameter :: nMax = 20
    integer :: i, lastMin, lastMax
    If(y <= 0 .OR. y >= 1) Then
      If(y == 0) Then
        x = 0
      Else If(y == 1) Then
        x = 1
      Else
        x = IEEE_VALUE(y, IEEE_QUIET_NAN)
      Endif
      RETURN
    Endif
    F = EXP(-LogBetaFunction(a,b))
    ! Evaluate first at y = x
    x = y
    xMin = 0d0; xMax = 1d0
    vMin = -y; vMax = 1d0-y
    dMin = 0d0; dMax = 0d0
    If(a <= 1) dMin = F*(0.5d0*EPSILON(0d0))**(a-1d0)*(1d0-0.5d0*EPSILON(0d0))**(b-1d0)
    If(.NOT. IEEE_IS_FINITE(dMin)) dMin = HUGE(1d0)
    If(b <= 1) dMax = F*(0.5d0*EPSILON(0d0))**(b-1d0)*(1d0-0.5d0*EPSILON(0d0))**(a-1d0)
    If(.NOT. IEEE_IS_FINITE(dMax)) dMax = HUGE(1d0)
    lastMin = 0; lastMax = 0
    Do i = 1, nMax
      If(lastMin-lastMax > 4) x = 0.5d0*(x+xMax)
      If(lastMax-lastMin > 4) x = 0.5d0*(x+xMin)
      V = IncompleteBeta(a, b, x) - y
      If(ABS(V) < 1d-30) RETURN
      dx = F*x**(a-1d0)*(1d0-x)**(b-1d0)
      If(ABS(V) < 1d-10*dx) Then
        ! Proceed a last Newton Raphson step before returning
        x = x -V/dx
        RETURN
      Endif
      If(V < 0) Then
        xMin = x; vMin = V; dMin = dx
        lastMin = i
      Else
        xMax = x; vMax = V; dMax = dx
        lastMax = i
      Endif
      d0 = MERGE(HUGE(1d0), dMin*(xMax-xMin)/(vMax-vMin), dMin == HUGE(1d0))
      d1 = MERGE(HUGE(1d0), dMax*(xMax-xMin)/(vMax-vMin), dMax == HUGE(1d0))
      !x = xMin + (xMax-xMin)*FindRoot2PDerivative(vMin, d0, vMax, d1)
      x = xMin + (xMax-xMin)*FindRoot3Bezier(d0, d1, -vMin/(vMax-vMin))
    End Do
  End Function QuantileBeta

  ! Compute the inverse CDF on a whole interval of values: used for integration
  Subroutine QuantileTableBeta(a, b, X)
    real(c_double), intent(in)  :: a, b
    real(c_double), intent(out) :: X(:)
    real(c_double) :: Y(SIZE(X)), DY(SIZE(X)), V, F, dx
    real(c_double) :: M0(3), M1(3), d0, d1, t, Z
    real(c_double) :: xMin, xMax, vMin, vMax, dMin, dMax
    integer :: i, j, k, N, lastMin, lastMax
    integer, parameter :: nMax = 10
    N = SIZE(X)
    X = [(REAL(i-1, 8)/REAL(N-1, 8), i=1,N)]
    X(1) = EPSILON(1d0)
    X(N) = 1d0 - EPSILON(1d0)
    Y = IncompleteBeta(a, b, X)
    Y(1) = 0d0; Y(N) = 1d0
    F = EXP(-LogBetaFunction(a,b))
    DY = F*X**(a-1d0)*(1d0-X)**(b-1d0)
    WHERE(.NOT. IEEE_IS_FINITE(DY)) DY = HUGE(1d0)
    j = 1
    M0 = [0d0, 0d0, DY(1)]
    M1 = [X(1), Y(1), DY(1)]
    X(1) = 0d0; X(N) = 1d0
    Do i = 2, N-1
      Z = X(i)
      Do While(Z > Y(j))
        j = j+1
        M0 = M1
        M1 = [REAL(j-1, 8)/REAL(N-1, 8), Y(j), DY(j)]
      End Do
      lastMin = 0; lastMax = 0
      xMin = M0(1); xMax = M1(1)
      vMin = M0(2)-Z; vMax = M1(2)-Z
      dMin = M0(3); dMax = M1(3)
      Do k = 1, nMax
        d0 = MERGE(HUGE(1d0), dMin*(xMax-xMin)/(vMax-vMin), dMin == HUGE(1d0))
        d1 = MERGE(HUGE(1d0), dMax*(xMax-xMin)/(vMax-vMin), dMax == HUGE(1d0))
        t = xMin + (xMax-xMin)*FindRoot3Bezier(d0, d1, -vMin/(vMax-vMin))
        If(lastMin-lastMax > 4) t = 0.5d0*(t+xMax)
        If(lastMax-lastMin > 4) t = 0.5d0*(t+xMin)
        V = IncompleteBeta(a, b, t) - Z
        dx = F*t**(a-1d0)*(1d0-t)**(b-1d0)
        If(ABS(V) < MIN(1d-10*dx, 1d-20)) EXIT
        If(V < 0) Then
          xMin = t; vMin = V; dMin = dx
          lastMin = i
        Else
          xMax = t; vMax = V; dMax = dx
          lastMax = i
        Endif
      End Do
      M0 = [t, V+Z, dx]
      ! Proceed a last Newton Raphson step before returning
      If(k <= nMax) t = t - V/dx
      X(i) = t
    End Do
  End Subroutine QuantileTableBeta

  ! Compute the probability that the distribution Beta(a,b) generates
  ! an element closer to z than the distribution whose Quantile Table is X
  ! (X generated by, for example, QuantileTableBeta)
  Real(c_double) Function IntegrateIncompleteBeta(X, a, b, z) Result(y)
    real(c_double), intent(in) :: X(:), a, b, z
    real(c_double), parameter :: icoeff(3) =  [3d0/8d0, 7d0/6d0, 23d0/24d0]
    integer :: N
    N = SIZE(X)
    y = (SUM(IC(X(4:N-3))) + DOT_PRODUCT(icoeff, IC(X(1:3))) &
       + DOT_PRODUCT(icoeff(3:1:-1), IC(X(N-2:N))))/REAL(N, 8)
  Contains
    Elemental Real(c_double) Function IC(t) Result(r)
      real(c_double), intent(in) :: t
      real(c_double) :: delta
      delta = ABS(t-z)
      If(t + delta < 1) Then
        r = IncompleteBeta(a, b, t+delta)
      Else
        r = 1
      Endif
      If(t - delta > 0) r = r - IncompleteBeta(a, b, t-delta)
    End Function IC
  End Function IntegrateIncompleteBeta

  ! Return the regularized incomplete beta function I_x(a,b)
  ! This algorithm is described in Numerical Recipes in C by Press
  ! (Chapter 6 Special Functions -> 6.4 Incomplete Beta Functions
  Elemental Real(c_double) Function IncompleteBeta(a, b, x) Result(y)
    real(c_double), intent(in) :: a, b, x
    real(c_double) :: F
    If(x <= 0 .OR. x >= 1) Then
      If(x == 0) Then
        y = 0
      Else If(x == 1) Then
        y = 1
      Else
        y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      Endif
      RETURN
    Endif
    F = EXP(a*LOG(x)+b*LOG(1d0-x)-LogBetaFunction(a,b))
    If(x < (a+1d0)/(a+b+2d0)) Then
      y = F*BCF(a,b,x)/a
    Else
      y = 1d0-F*BCF(b,a,1-x)/b
    Endif
  Contains
    Pure Real(c_double) Function BCF(a, b, x) Result(y)
      real(c_double), intent(in) :: a, b, x
      integer, parameter :: nMax = 200
      integer :: i
      real(c_double) :: num, c, d
      real(c_double), parameter :: tinyX = 1d-30, eps = 1d-15
      c = 1d0; d = MAX(1d0 - (a+b)*x/(a+1), tinyX)
      d = 1d0/d
      y = d
      Do i=1,nMax
        ! Proceed two iterations of the Lentz's algorithm for
        ! the evaluation of continued fractions
        ! Odd iteration
        num = i*(b-i)*x/((a+2*i-1)*(a+2*i))
        d = 1d0 + num*d
        If(ABS(d) < tinyX) d = tinyX
        d = 1d0/d
        c = 1d0+num/c
        If(ABS(c) < tinyX) c = tinyX
        y = y*c*d
        ! Even iteration
        num = -(a+i)*(a+b+i)*x/((a+2*i)*(a+2*i+1))
        d = 1d0 + num*d
        If(ABS(d) < tinyX) d = tinyX
        d = 1d0/d
        c = 1d0+num/c
        If(ABS(c) < tinyX) c = tinyX
        y = y*c*d
        If(ABS(1d0-c*d) < eps) RETURN
      End Do
      ! Error: has not converge after nMax iterations
      y = IEEE_VALUE(y, IEEE_QUIET_NAN)
    End Function BCF
  End Function IncompleteBeta

  Integer Function MaxLikelihoodBetaPriorBeta(X, alpha, beta, p_alpha, p_beta, a, b) Result(info)
    real(c_double), intent(in) :: X(:), p_alpha, p_beta
    real(c_double), intent(in), optional :: a, b
    real(c_double), intent(out) :: alpha, beta
    real(c_double) :: invAB, lGa, lGb, mu, var, invN, u
    real(c_double) :: dX(2), psi(3), psi2(3), haa, hab, hbb
    real(c_double) :: a0, b0, da, db, df, d2f, dY(2), y
    integer, parameter :: nMax = 100
    real(c_double), parameter :: eps = 1d-9
    integer :: N, i
    info = -1
    N = SIZE(X)
    invN = 1d0/(REAL(N, KIND=8))
    mu = SUM(X)*invN
    If(PRESENT(a) .OR. PRESENT(b)) Then
      CALL InitOrDefault(a0, a, 0d0)
      CALL InitOrDefault(b0, b, 1d0)
      invAB = 1d0/(b0-a0)
      ! Compute the logarithm of the geometric mean of X-a and b-X
      lGa = SUM(LOG((X-a0)*invAB))*invN
      lGb = SUM(LOG((b0-X)*invAB))*invN
      ! Compute mean and variance of X
      var = SUM(((X-mu)*invAB)**2)/REAL(N-1,KIND=8)
      mu = (mu-a0)*invAB
    Else
      lGa = SUM(LOG(X))*invN
      lGb = SUM(LOG(1d0-X))*invN
      var = SUM((X-mu)**2)/REAL(N-1,KIND=8)
    Endif
    u = mu*(1-mu)
    If(var < u) Then
      ! Use the method of moments to estimate alpha and beta
      u = u/var-1 ! positive
      alpha = mu*u
      beta = (1-mu)*u
    Else
      ! N.L. Johnson and S. Kotz estimation from Continous Univariate Distribution Vol. 2
      u = 1d0/(1-EXP(lGa)-EXP(lGb))
      alpha = 0.5d0*(1d0+EXP(lGa)*u)
      beta  = 0.5d0*(1d0+EXP(lGb)*u)
    Endif
    ! Do a few iteration of the Newton's methods using the Hessian matrix
    Do i = 1, nMax
      ! Compute psi and psi'
      psi  = Digamma([alpha, beta, alpha+beta])
      psi2 = Trigamma([alpha, beta, alpha+beta])
      y = alpha/(alpha+beta)
      df = (p_alpha-1)/y - (p_beta-1)/(1-y)
      d2f = -(p_alpha-1)/y**2 - (p_beta-1)/(1-y)**2
      dY = 1/(alpha+beta)*[-y, 1-y]
      ! Compute the gradient dX and the hessian matrix H=[haa hab; hab hbb]
      dX = [lGa, lGb] - psi(1:2) + psi(3) + df*dY/N
      haa = psi2(3)-psi2(1) + d2f*dY(1)**2 + df*2*(1-y)/(alpha+beta)**2/N
      hbb = psi2(3)-psi2(2) + d2f*dY(2)**2 + df*2*y/(alpha+beta)**2/N
      hab = psi2(3) + d2f*dY(1)*dY(2) + df*(2-y)/(alpha+beta)**2/N
      u = haa*hbb-hab**2
      If(u == 0d0) RETURN
      u = 1d0/u
      ! Apply a Newton step on [alpha beta]
      da = -u*(hbb*dX(1)-hab*dX(2))
      db = -u*(haa*dX(2)-hab*dX(1))
      alpha = MAX(0d0, alpha + da)
      beta = MAX(0d0, beta + db)
      If(ABS(da) < eps*alpha .AND. ABS(db) < eps*beta) EXIT
    End Do
    info = 0
  End Function MaxLikelihoodBetaPriorBeta

  Integer Function MaxLikelihoodBeta(X, alpha, beta, W, a, b) Result(info)
    real(c_double), intent(in) :: X(:)
    real(c_double), intent(in), optional :: a, b, W(:)
    real(c_double), intent(out) :: alpha, beta
    real(c_double) :: invAB, lGa, lGb, mu, var, invN, u
    real(c_double) :: dX(2), psi(3), psi2(3), haa, hab, hbb
    real(c_double) :: a0, b0, da, db
    integer, parameter :: nMax = 100
    real(c_double), parameter :: eps = 1d-12
    integer :: N, i
    info = -1
    N = SIZE(X)
    If(PRESENT(W)) Then
      invN = 1d0/SUM(W)
      mu = SUM(W*X)*invN
    Else
      invN = 1d0/(REAL(N, KIND=8))
      mu = SUM(X)*invN
    Endif
    If(PRESENT(a) .OR. PRESENT(b)) Then
      CALL InitOrDefault(a0, a, 0d0)
      CALL InitOrDefault(b0, b, 1d0)
      invAB = 1d0/(b0-a0)
      If(PRESENT(W)) Then
        lGa = SUM(W*LOG((X-a0)*invAB))*invN
        lGb = SUM(W*LOG((b0-X)*invAB))*invN
      Else
        ! Compute the logarithm of the geometric mean of X-a and b-X
        lGa = SUM(LOG((X-a0)*invAB))*invN
        lGb = SUM(LOG((b0-X)*invAB))*invN
      Endif
      ! Compute mean and variance of X
      If(PRESENT(W)) Then
        var = SUM(W*((X-mu)*invAB)**2)*REAL(N,8)/REAL(N-1,8)*invN
      Else
        var = SUM(((X-mu)*invAB)**2)/REAL(N-1,8)
      Endif
      mu = (mu-a0)*invAB
    Else If(PRESENT(W)) Then
      lGa = SUM(W*LOG(X))*invN
      lGb = SUM(W*LOG(1d0-X))*invN
      ! Unbiased weighted estimate of variance
      var = SUM(W*(X-mu)**2)/(1/invN-SUM(W*W)*invN)
    Else
      lGa = SUM(LOG(X))*invN
      lGb = SUM(LOG(1d0-X))*invN
      var = SUM((X-mu)**2)/REAL(N-1,KIND=8)
    Endif
    u = mu*(1-mu)
    If(var < u) Then
      ! Use the method of moments to estimate alpha and beta
      u = u/var-1 ! positive
      alpha = mu*u
      beta = (1-mu)*u
    Else
      ! N.L. Johnson and S. Kotz estimation from Continous Univariate Distribution Vol. 2
      u = 1d0/(1-EXP(lGa)-EXP(lGb))
      alpha = 0.5d0*(1d0+EXP(lGa)*u)
      beta  = 0.5d0*(1d0+EXP(lGb)*u)
    Endif
    ! Do a few iteration of the Newton's methods using the Hessian matrix
    Do i = 1, nMax
      ! Compute psi and psi'
      psi  = Digamma([alpha, beta, alpha+beta])
      psi2 = Trigamma([alpha, beta, alpha+beta])
      ! Compute the gradient dX and the hessian matrix H=[haa hab; hab hbb]
      dX = [lGa, lGb] - psi(1:2) + psi(3)
      haa = psi2(3)-psi2(1)
      hbb = psi2(3)-psi2(2)
      hab = psi2(3)
      u = haa*hbb-hab**2
      If(u == 0d0) RETURN
      u = 1d0/u
      ! Apply a Newton step on [alpha beta]
      da = -u*(hbb*dX(1)-hab*dX(2))
      db = -u*(haa*dX(2)-hab*dX(1))
      alpha = MAX(0d0, alpha + da)
      beta = MAX(0d0, beta + db)
      If(MAX(ABS(da), ABS(dX(1))) < eps*alpha .AND. &
         MAX(ABS(db), ABS(dX(2))) < eps*beta) EXIT
    End Do
    info = 0
  End Function MaxLikelihoodBeta
End Module mlf_beta_dist


*deck qpasy
      subroutine qpasy(alpha,dfac,npi,l,lambu,lmahi,lmbhi,ltot1,xka,
     &  xkb,prd,dum,qsum)
c
c  compute type 2 radial integrals, scaled by exp(-arc2)/sqrt(pi),
c  using the partially asymptotic method,
c  for lama=l to lmahi, lamb=l to lmbhi, n=lama+lamb-l-l
c
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, accrcy=1.0d-13, a1s4=0.25d0, a1s2=0.5d0,
     1  a1=1.0d0)
      dimension dfac(*),qsum(ltot1,lambu,*)
c
      sqalpi=a1/sqrt(alpha)
      alf1=a1
      if(xka.gt.xkb) go to 42
c
c  xka is smaller: set up parameters for qcomp using xkb
c
      xk=xkb*sqalpi
      t=a1s4*xk*xk
      prde=prd*exp(t-dum)*sqalpi**(npi+l)
      if(l.ge.2) prde=prde*xka**(l-1)
      tk=xka*xka/(alpha+alpha)
      do 30 lama=l,lmahi
      la=lama-1
      prefac=prde
      do 28 lamb=l,lmbhi
      lb=lamb-1
      n=((1-l-l)+lama)+lamb
c     # run power series using xka, obtaining initial
c     # q(n,l) values from qcomp, then recurring upwards
c     # j=0 term in sum
      nprime=npi+n+la-1
      qold1=qcomp(alf1,dfac,nprime,lb,t,xk)/dfac(la+la+3)
      sum=qold1
      if(tk.eq.a0) go to 24
c     # j=1 term in sum
      nprime=nprime+2
      qnew=qcomp(alf1,dfac,nprime,lb,t,xk)/dfac(la+la+3)
      f1=(la+la+3)
      qold2=(tk/f1)*qold1
      qold1=(tk/f1)*qnew
      sum=sum+qold1
      j=1
c     # increment j for next term
   22 j=j+1
      nprime=nprime+2
      f1=(nprime+nprime-5)
      f2=((lb-nprime+4)*(lb+nprime-3))
      qnew=(t+a1s2*f1)*qold1+a1s4*f2*qold2
      f1=(j*(la+la+j+j+1))
      qold2=(tk/f1)*qold1
      qold1=(tk/f1)*qnew
      sum=sum+qold1
      if(qold1.gt.accrcy*sum) go to 22
   24 qsum(n,lamb,lama)=qsum(n,lamb,lama)+prefac*sum
      prefac=prefac*sqalpi
   28 continue
      prde=prde*(xka/alpha)
   30 continue
      return
c
c  xkb is smaller: set up parameters for qcomp using xka
c
   42 xk=xka*sqalpi
      t=a1s4*xk*xk
      prde=prd*exp(t-dum)*sqalpi**(npi+l)
      if(l.ge.2) prde=prde*xkb**(l-1)
      tk=xkb*xkb/(alpha+alpha)
      do 60 lama=l,lmahi
      la=lama-1
      prefac=prde
      do 58 lamb=l,lmbhi
      lb=lamb-1
      n=((1-l-l)+lama)+lamb
c     # run power series using xkb, obtaining initial
c     # q(n,l) values from qcomp, then recurring upwards
c     # j=0 term in sum
      nprime=npi+n+lb-1
      qold1=qcomp(alf1,dfac,nprime,la,t,xk)/dfac(lb+lb+3)
      sum=qold1
      if(tk.eq.a0) go to 54
c     # j=1 term in sum
      nprime=nprime+2
      qnew=qcomp(alf1,dfac,nprime,la,t,xk)/dfac(lb+lb+3)
      f1=(lb+lb+3)
      qold2=(tk/f1)*qold1
      qold1=(tk/f1)*qnew
      sum=sum+qold1
      j=1
c     # increment j for next term
   52 j=j+1
      nprime=nprime+2
      f1=(nprime+nprime-5)
      f2=((la-nprime+4)*(la+nprime-3))
      qnew=(t+a1s2*f1)*qold1+a1s4*f2*qold2
      f1=(j*(lb+lb+j+j+1))
      qold2=(tk/f1)*qold1
      qold1=(tk/f1)*qnew
      sum=sum+qold1
      if(qold1.gt.accrcy*sum) go to 52
   54 qsum(n,lamb,lama)=qsum(n,lamb,lama)+prefac*sum
      prefac=prefac*(xkb/alpha)
   58 continue
      prde=prde*sqalpi
   60 continue
      return
      end


      SUBROUTINE RATINT(XA,YA,N,X,Y,DY)
      PARAMETER (NMAX=10,TINY=1.E-25)
      DIMENSION XA(N),YA(N),C(NMAX),D(NMAX)
      NS=1
      HH=ABS(X-XA(1))
      DO 11 I=1,N
        H=ABS(X-XA(I))
        IF (H.EQ.0.)THEN
          Y=YA(I)
          DY=0.0
          RETURN
        ELSE IF (H.LT.HH) THEN
          NS=I
          HH=H
        ENDIF
        C(I)=YA(I)
        D(I)=YA(I)+TINY
11    CONTINUE
      Y=YA(NS)
      NS=NS-1
      DO 13 M=1,N-1
        DO 12 I=1,N-M
          W=C(I+1)-D(I)
          H=XA(I+M)-X
          T=(XA(I)-X)*D(I)/H
          DD=T-C(I+1)
          IF(DD.EQ.0.)PAUSE
          DD=W/DD
          D(I)=C(I+1)*DD
          C(I)=T*DD
12      CONTINUE
        IF (2*NS.LT.N-M)THEN
          DY=C(NS+1)
        ELSE
          DY=D(NS)
          NS=NS-1
        ENDIF
        Y=Y+DY
13    CONTINUE
      RETURN
      END


      REAL FUNCTION BESSJ1(X)
      IMPLICIT NONE
C-----------------------------------------------------------------------
C Purpose: Calculate J1(X)
C
C Arguments:
C
      REAL X
C
C Local Arrays:
C
      REAL*8 PCOF(0:4),QCOF(0:4),RCOF(0:5),SCOF(0:5)
C
C Local Scalars:
C
      REAL*8 Y,AX,Z,DX,XX,TMP1,TMP2
      INTEGER I
C
C Data:
C
      DATA PCOF/-0.2403370190D-06, 0.2457520174D-05,-0.3516396496D-04,
     &           0.1831050000D-02, 1.0D0/
      DATA QCOF/ 0.1057874120D-06,-0.8822898700D-06, 0.8449199096D-05,
     &          -0.2002690873D-03, 0.4687499995D-01/
      DATA RCOF/-0.3016036606D+02, 0.1570448260D+05,-0.2972611439D+07,
     &           0.2423968531D+09,-0.7895059235D+10, 0.72362614232D+11/
      DATA SCOF/ 1.0D0           , 0.3769991397D+03, 0.9944743394D+05,
     &           0.1858330474D+08, 0.2300535178D+10, 0.144725228442D+12/
C
C-----------------------------------------------------------------------
      DX = DBLE(X)
      IF(ABS(X).LT.8.0)THEN
         Y = DX*DX
         TMP1 = RCOF(0)
         TMP2 = SCOF(0)
         DO 10 I=1,5
            TMP1 = TMP1*Y + RCOF(I)
            TMP2 = TMP2*Y + SCOF(I)
 10      CONTINUE
         BESSJ1 = SNGL(DX*TMP1/TMP2)
      ELSE
         AX = ABS(DX)
         Z = 8.0D0/AX
         Y = Z*Z
         XX = AX - 2.356194491D0
         TMP1 = PCOF(0)
         TMP2 = QCOF(0)
         DO 20 I=1,4
            TMP1 = TMP1*Y + PCOF(I)
            TMP2 = TMP2*Y + QCOF(I)
 20      CONTINUE
         BESSJ1 = SNGL(SQRT(0.636619772D0/AX)
     &                 *(COS(XX)*TMP1-Z*SIN(XX)*TMP2))*SIGN(1.0,X)
      ENDIF
      RETURN
      END