program test_randomnumbers
      implicit none
      integer:: nbins, k, i, j
      real*8:: p, xavg, xsqr_avg,sigma, x_ik
      real*8, dimension(:), allocatable::index_array,rdn_array,ck_array,ck

      nbins = 10000
      allocate(rdn_array(nbins))
      allocate(index_array(nbins))
      allocate(ck_array(nbins-1))
      allocate(ck(nbins-1))

      ! index_array stores the indices 1:n
      do i=1,nbins-1
        index_array(i)=i
      end do

      ! rdn_array stores random numbers from the distribution
      ! 2exp(-2x)dx. We use -0.5log(x) for the same
      do i=1,nbins
        call random_number(p)
        rdn_array(i) = -0.50d0*log(p)
      end do

      ! We write the array of random numbers in a file
      open(unit=5, file="20181044_p1_randomnumbers.dat")
      do i=1,nbins
        write(5,*) rdn_array(i)
      end do
      print*,"Random numbers written to 20181044_p1_randomnumbers.dat "

      ! xavg stores the averages value of the random variable
      ! xsqr_avg stores the average value of the squares
      xavg=0
      xsqr_avg=0
      do i=1,nbins
        xavg = xavg+rdn_array(i)
        xsqr_avg = xsqr_avg+(rdn_array(i)*rdn_array(i))
      end do
      xavg = xavg/real(nbins)
      xsqr_avg = xsqr_avg/real(nbins)

      sigma=sqrt(xsqr_avg - (xavg*xavg))

      write(*,*) "The mean is =", xavg
      write(*,*) "The std dev is =", sigma

      ! Now we compute the Correlation values
      ! ck_arry stores the correlation values

      print*, "Computing the autocorrelation of the random numbers ..."
      x_ik=0
      do i=1, nbins-1
        k = i
        do j=1,nbins-k
            x_ik = x_ik + rdn_array(j)*rdn_array(j+k)
        end do
        x_ik = x_ik/real(nbins-k)
        ck_array(i) = x_ik
      end do

      ! Now we compute the Correlation values and store that in ck
      do i=1, nbins-1
        ck(i) = (ck_array(i) - (xavg*xavg))/(sigma*sigma)
      end do

      open(unit=7, file="20181044_p1_ckvalues.dat")
      do i=1,nbins-1
        write(7,*) index_array(i), ck(i)
      end do
      print*,"Done! Autocorrelation data stored in 20181044_p1_ckvalues.dat"

       ! Print scatter plot
       print*, "Computing scatterplot"
       open(unit=9, file="20181044_p1_scattervalues.dat")
       do i=1, nbins-1
           write(9,*) rdn_array(i+1), rdn_array(i)
       end do
       print*,"Scatter plot data avaiable at 20181044_p1_scattervalues.dat"

end program test_randomnumbers


Real Function w1440(dmass)
  Save
  avmass = 0.938868
  pimass = 0.137265
  aux = 0.25*(dmass**2-avmass**2-pimass**2)**2 - (avmass*pimass)**2
  If (aux>0.) Then
     qavail = sqrt(aux)/dmass
  Else
     qavail = 1.E-06
  End If
  w1440 = 0.2*(qavail/0.397)**3
  Return
End Function w1440


      DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB,
     $                                  C, LDC, HSV, DWORK, LDWORK,
     $                                  INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Hankel-norm of the transfer-function matrix G of
C     a stable state-space system (A,B,C). The state dynamics matrix A
C     of the given system is an upper quasi-triangular matrix in
C     real Schur form.
C
C     FUNCTION VALUE
C
C     AB13AX  DOUBLE PRECISION
C             The Hankel-norm of G (if INFO = 0).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state dynamics matrix A in a real Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, this array contains the Hankel singular
C             values of the given system ordered decreasingly.
C             HSV(1) is the Hankel norm of the given system.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2).
C             For optimum performance LDWORK should be larger.
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             = 1:  the state matrix A is not stable (if DICO = 'C')
C                   or not convergent (if DICO = 'D');
C             = 2:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the stable linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t)                               (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let G be the corresponding
C     transfer-function matrix. The Hankel-norm of G is computed as the
C     the maximum Hankel singular value of the system (A,B,C).
C     The computation of the Hankel singular values is performed
C     by using the square-root method of [1].
C
C     REFERENCES
C
C     [1] Tombs M.S. and Postlethwaite I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     NUMERICAL ASPECTS
C
C     The implemented method relies on a square-root technique.
C                                     3
C     The algorithms require about 17N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine SHANRM.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest.
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Multivariable system, state-space model, system norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           I, IERR, J, KR, KS, KTAU, KU, KW, MNMP
      DOUBLE PRECISION  SCALEC, SCALEO, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) +
     $                         ( N*( N + 1 ) )/2 ) ) THEN
         INFO = -13
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13AX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         AB13AX = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the
C     matrices S, TAU, and R, respectively. S shares the storage with U.
C
      KU   = 1
      KS   = 1
      MNMP = MAX( N, M, P )
      KTAU = KS + N*MNMP
      KR   = KTAU + N
      KW   = KR
C
C     Copy C in U.
C
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP )
C
C     If DISCR = .FALSE., solve for R the Lyapunov equation
C                                  2
C     A'*(R'*R) + (R'*R)*A + scaleo  * C'*C = 0 .
C
C     If DISCR = .TRUE., solve for R the Lyapunov equation
C                         2
C     A'*(R'*R)*A + scaleo  * C'*C = R'*R .
C
C     Workspace needed:      N*(MAX(N,M,P)+1);
C     Additional workspace:  need   4*N;
C                            prefer larger.
C
      CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP,
     $             DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW),
     $             LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 1
         RETURN
      ENDIF
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
C     Pack the upper triangle of R in DWORK(KR).
C     Workspace needed:      N*(MAX(N,M,P) + 1) + N*(N+1)/2.
C
      CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) )
C
      KW = KR + ( N*( N + 1 ) )/2
C
C     Copy B in S (over U).
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N )
C
C     If DISCR = .FALSE., solve for S the Lyapunov equation
C                                  2
C     A*(S*S') + (S*S')*A' + scalec *B*B' = 0 .
C
C     If DISCR = .TRUE., solve for S the Lyapunov equation
C                         2
C     A*(S*S')*A' + scalec *B*B' = S*S' .
C
C     Workspace needed:      N*(MAX(N,M,P) + 1) + N*(N+1)/2;
C     Additional workspace:  need   4*N;
C                            prefer larger.
C
      CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N,
     $             DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW),
     $             LDWORK-KW+1, IERR )
C
      WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) )
C
C                             | x x |
C     Compute R*S in the form | 0 x | in S. Note that R is packed.
C
      J = KS
      DO 10 I = 1, N
         CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR),
     $               DWORK(J), 1 )
         J = J + N
   10 CONTINUE
C
C     Compute the singular values of the upper triangular matrix R*S.
C
C     Workspace needed:      N*MAX(N,M,P);
C     Additional workspace:  need   MAX(1,5*N);
C                            prefer larger.
C
      KW = KTAU
      CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1,
     $             HSV, DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 2
         RETURN
      ENDIF
C
C     Scale singular values.
C
      CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 )
      AB13AX = HSV(1)
C
      DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) )
C
      RETURN
C *** Last line of AB13AX ***
      END


!#########################################################
!#########################################################
!#########################################################
!#########################################################
subroutine rho_ana(x,d,dx,ncell)
  use amr_parameters
  use hydro_parameters
  use poisson_parameters
  implicit none
  integer ::ncell                         ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector)       ::d ! Density
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates analytical Poisson source term.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! d(i) is the density field in user units.
  !================================================================
  integer::i
  real(dp)::dmass,emass,xmass,ymass,zmass,rr,rx,ry,rz,dd

  emass=gravity_params(1) ! Softening length
  xmass=gravity_params(2) ! Point mass coordinates
  ymass=gravity_params(3)
  zmass=gravity_params(4)
  dmass=1.0/(emass*(1.0+emass)**2)

  do i=1,ncell
     rx=0.0d0; ry=0.0d0; rz=0.0d0
     rx=x(i,1)-xmass
#if NDIM>1
     ry=x(i,2)-ymass
#endif
#if NDIM>2
     rz=x(i,3)-zmass
#endif
     rr=sqrt(rx**2+ry**2+rz**2)
     dd=1.0/(rr*(1.0+rr)**2)
     d(i)=MIN(dd,dmass)
  end do

end subroutine rho_ana


      double complex function Alcphiqarbmpmp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      include 'deltar.f'
C     arXIv:09060008v1, Eq.4.9
c--- the function defined in this routine is in fact (-i*A_4),
c---   i.e. complete LHS
      double precision s12,s13,s41,s23,s24,s34
      double precision s123,s234,s341,s412,mhsq
      double complex Vlc,Lsm1DS,Lsm1_2me,L0,L1,lnrat,
     & A0phiqarbmpmp,A0phidqarbmpmp
      integer j1,j2,j3,j4

      s12=s(j1,j2)
      s13=s(j1,j3)
      s41=s(j4,j1)
      s23=s(j2,j3)
      s24=s(j2,j4)
      s34=s(j3,j4)
      s123=s12+s13+s23
      s234=s23+s24+s34
      s341=s34+s41+s13
      s412=s41+s12+s24
      mhsq=s12+s13+s41+s23+s24+s34

C---arXIv:09060008v1 Eq.(4.9)
      Vlc = -2d0*epinv**2
     &  -epinv*lnrat(musq,-s23)-epinv*lnrat(musq,-s41)
     &  -0.5d0*lnrat(musq,-s23)**2-0.5d0*lnrat(musq,-s41)**2
     & +13d0/6d0*(2d0*epinv+lnrat(musq,-s12)+lnrat(musq,-s34))
     & - Lsm1_2me(s123,s234,s23,mhsq)
     % - Lsm1_2me(s341,s412,s41,mhsq)
     & - Lsm1DS(s23,s34,s234)
     & - Lsm1DS(s34,s41,s341)
     & - Lsm1DS(s41,s12,s412)
     & - Lsm1DS(s12,s23,s123)
     & + 101d0/9d0 - deltar/3d0

C---arXIv:09060008v1 Eq.(4.13)
      Alcphiqarbmpmp=
     & A0phiqarbmpmp(j1,j2,j3,j4,za,zb)*(Vlc
     & +(1d0 -(za(j1,j4)*za(j2,j3)/(za(j1,j3)*za(j2,j4)))**2)
     & *(Lsm1DS(s23,s34,s234) +Lsm1DS(s41,s12,s412)))
     & - 0.5d0*za(j1,j2)*za(j3,j4)/za(j2,j4)**2
     & *(s41**2*L1(-s412,-s12)/s12**2+s23**2*L1(-s234,-s34)/s34**2
     & - lnrat(-s412,-s12)-lnrat(-s234,-s34))
     & + 2*zb(j2,j4)/za(j2,j4)
     & *(za(j2,j3)/zb(j1,j4)
     &  *(s24*L0(-s412,-s12)/s12+lnrat(-s412,-s12))
     & +za(j1,j4)/zb(j2,j3)
     & *(s24*L0(-s234,-s34)/s34+lnrat(-s234,-s34)))
     & + za(j1,j4)*za(j2,j3)*zb(j2,j4)/za(j2,j4)
     &  *(L0(-s412,-s41)/s41+L0(-s234,-s23)/s23)
     & - 0.5d0/za(j2,j4)**2
     & *(za(j3,j4)*(s24-s41)/zb(j1,j2)
     & +za(j1,j2)*(s24-s23)/zb(j3,j4))
     & -2d0*A0phidqarbmpmp(j1,j2,j3,j4,za,zb)

      return
      end


      DOUBLE PRECISION FUNCTION PHO_DOR94FW(X,S,Al,Be,Ak,Bk,A,B,C,D,E,
     &   Es)
      IMPLICIT NONE
      DOUBLE PRECISION A , Ak , Al , B , Be , Bk , C , D , E , Es , lx ,
     &                 S , X
      SAVE

      lx = LOG(1./X)
      PHO_DOR94FW = (X**Ak*(A+X*(B+X*C))
     &              *lx**Bk+S**Al*EXP(-E+SQRT(Es*S**Be*lx)))*(1.-X)**D

      END FUNCTION


      COMPLEX*16 FUNCTION javsubU0(Qs,Us,mtp2,mbt2,mv2)
*------------------------------------------------------
      REAL*8 Qs,Us,zet2,rmv2,eps
      COMPLEX*16 mtp2,mbt2,mv2,ieps,XSPENZ
      PARAMETER (eps=1D-20)
      PARAMETER (zet2=1.6449340668482264364724151666460251D0)
      ieps=DCMPLX(0d0,eps)
      rmv2=DREAL(mv2)
*
      javsubU0=
     &+1d0/Qs*(
     &   +CDLOG(-Qs/(Qs-ieps))*CDLOG((Qs+mv2)/rmv2)
     &   -1d0/2*CDLOG(-mv2/(Qs+mv2))**2
     &   +1d0/2*CDLOG(+mv2/(Qs+mv2))**2
     &   -3*zet2)
     &-1d0/(mtp2+Us)*(
     &   +CDLOG(Qs*mtp2/(mtp2+Us)**2)*CDLOG((Qs+mv2)/mv2)
     &   -1d0/2*CDLOG(mv2/(Qs+mv2))**2
     &   -XSPENZ((Us+mtp2-mv2)/(-mv2))
     &   -XSPENZ(mv2/(Qs+mv2))
     &   +2*zet2     )
*---------------------
      RETURN
      END


program rand_test
    use, intrinsic :: iso_fortran_env, only : sp => REAL32, dp => REAL64
    use random_mod, only : random_normal_number
    implicit none
    integer, parameter :: N = 10000
    real(kind=dp) :: r
    integer :: i

    do i = 1, N
        call random_normal_number(r)
        print *, r
    end do

end program rand_test


program main
    use forlab, only: issquare, eye, disp
    implicit none
    real, dimension(:, :), allocatable :: A

    A = eye(2, 2)
    call disp(size(A, 1), 'size 1:')
    call disp(size(A, 2), 'size 2:')
    call disp(size(A), 'size 3:')
    call disp(issquare(A), 'eye(2,2) issquare:')

    A = eye(2, 3)
    call disp(size(A, 1), 'size 1:')
    call disp(size(A, 2), 'size 2:')
    call disp(size(A), 'size 3:')
    call disp(issquare(A), 'eye(2,3) issquare:')

end program


      MODULE m_matmul
!
! makes a matrix-matrix multiplication for 3x3 matrices A and B
! whereby      A       B
!            integer  integer  ... matmul1
!            real     real     ... matmul2
!            integer  real     ... matmul3
! additionally, integer rotation matrices + nonsymmorphic
! translations can be multiplied in matmul4
!
      CONTAINS
!--------------------------------------------------------
      SUBROUTINE matmul1 (ma,mb,mc)

      IMPLICIT NONE
      INTEGER, INTENT (IN) :: ma(3,3)
      INTEGER, INTENT (IN) :: mb(3,3)
      INTEGER, INTENT (OUT):: mc(3,3)

      INTEGER :: i,j,k

      INTEGER x
      DO i=1,3
         DO k=1,3
         x = 0
            DO j=1,3
               x = x + ma(i,j)*mb(j,k)
            ENDDO
         mc(i,k) = x
         END DO
      END DO

      END SUBROUTINE matmul1
!--------------------------------------------------------
      SUBROUTINE matmul2 (a,b,c)

      IMPLICIT NONE
      REAL,    INTENT (IN) :: a(3,3)
      REAL,    INTENT (IN) :: b(3,3)
      REAL,    INTENT (OUT):: c(3,3)

      INTEGER :: i,j,k
      REAL x
      DO i=1,3
         DO k=1,3
         x=0.e0
            DO j=1,3
               x = x + a(i,j)*b(j,k)
            ENDDO
         c(i,k) = x
         END DO
      END DO

      END SUBROUTINE matmul2
!--------------------------------------------------------
      SUBROUTINE matmul3 (ma,b,c)

      IMPLICIT NONE
      INTEGER, INTENT (IN) :: ma(3,3)
      REAL,    INTENT (IN) ::  b(3,3)
      REAL,    INTENT (OUT)::  c(3,3)

      INTEGER :: i,j,k
      REAL x
      DO i=1,3
         DO k=1,3
         x=0.e0
            DO j=1,3
               x = x + ma(i,j)*b(j,k)
            ENDDO
         c(i,k) = x
         END DO
      END DO

      END SUBROUTINE matmul3
!--------------------------------------------------------
      SUBROUTINE matmul3r (ma,b,c)

      REAL, INTENT (IN) :: ma(3,3)
      REAL, INTENT (IN) ::  b(3,3)
      REAL, INTENT (OUT)::  c(3,3)

      INTEGER :: i,j,k
      REAL x
      DO i=1,3
         DO k=1,3
         x=0.e0
            DO j=1,3
               x = x + ma(i,j)*b(j,k)
            ENDDO
         c(i,k) = x
         END DO
      END DO
      RETURN
      END SUBROUTINE matmul3r
!--------------------------------------------------------
      SUBROUTINE matmul4 (ma,ta,mb,tb,mc,tc)

      IMPLICIT NONE
      INTEGER, INTENT (IN) :: ma(3,3),mb(3,3)
      REAL,    INTENT (IN) :: ta(3),tb(3)
      INTEGER, INTENT (OUT):: mc(3,3)
      REAL,    INTENT (OUT):: tc(3)

      INTEGER :: i,j,k
      REAL x,xa(4,4),xb(4,4),xc(4,4)

      xa(:,:) = 0.0 ; xa(4,4) = 1.0 ; xb(:,:) = xa(:,:)
      xa(1:3,1:3) = real(ma(1:3,1:3)) ; xa(1:3,4) = ta(:)
      xb(1:3,1:3) = real(mb(1:3,1:3)) ; xb(1:3,4) = tb(:)
      DO i=1,4
         DO k=1,4
         x=0.e0
            DO j=1,4
               x = x + xa(i,j)*xb(j,k)
            ENDDO
         xc(i,k) = x
         END DO
      END DO
      mc(1:3,1:3) = nint(xc(1:3,1:3)) ; tc(:) = xc(1:3,4)
      DO i = 1,3
        IF (tc(i).GT.1.0) THEN
          tc(i) = tc(i) - int(tc(i))
        ELSEIF (tc(i).LT.0.0) THEN
          tc(i) = tc(i) + int(tc(i)) + 1
        ENDIF
      ENDDO

      END SUBROUTINE matmul4

      END MODULE m_matmul


! =====================================================================
! function KP2XV
!
! This function computes the expectation value of the angular momentum
! operator squared.
! ---------------------------------------------------------------------
      double precision function KP2XV(nRP,nR,nP,dP,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dP
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: XV
      double complex :: a
      double complex :: b

      KP2XV = 0.0d0
      a = dcmplx(2.0d0/dP**2,0.0d0)
      b = dcmplx(1.0d0/dP**2,0.0d0)

      k = 0
      do j = 1, nR
      k = k + 1
         XV = dble(dconjg(U(k))*(a*U(k)-b*(U(k+nP-1)+U(k+1))))
         KP2XV = KP2XV + XV*RdRP(j)
         do i = 2, nP-1
            k = k + 1
            XV = dble(dconjg(U(k))*(a*U(k)-b*(U(k-1)+U(k+1))))
            KP2XV = KP2XV + XV*RdRP(j)
         enddo
         k = k + 1
         XV = dble(dconjg(U(k))*(a*U(k)-b*(U(k-1)+U(k-nP+1))))
         KP2XV = KP2XV + XV*RdRP(j)
      enddo

      return
      end
! =====================================================================


	  subroutine reacrates(Tn,TnHot,TOx,TH,TOHot,kOH,kHO,kOHotH,kHOHot
     &       ,khothot)

!	This subroutine computes the reaction rates for in units of cm^3/s
!
!	1)	O+ + H --> H+ + O
!	2)	H+ + O --> O+ + H
!
!	as indicated by Stancil, et al, AAS, 1999

	  real TOx,TH,TOHot,kOH,kHO,KOHotH,KHOHot
	  real Tr,b1(2),c1(2),b2(2),c2(2)

!	Reaction 1) above
	  data b1 /2.08e-9,1.11e-11/
	  data c1 /4.05e-1,-4.58e-1/

!	Reaction 2) above
	  data b2 /1.26e-9,4.25e-10/
	  data c2 /5.17e-1,6.69e-3/

!	Cold reaction rates
      Tr=(Tn +16.*TOx)/17.
      kOH=b1(1)*(Tr/1.e4)**c1(1) + b1(2)*(Tr/1.e4)**c1(2)
      Tr=(Tn*16.+TH)/17.
      kHO=(b2(1)*(Tr/1.e4)**c2(1) + b2(2)*(Tr/1.e4)**c2(2))*
     &  exp(-227./Tr)
!	Hot reaction rates
	  Tr=(Tn +16.*TOHot)/17.
	  kOHotH=b1(1)*(Tr/1.e4)**c1(1) + b1(2)*(Tr/1.e4)**c1(2)
      Tr=(TnHot*16.+TH)/17.
	  kHOHot=(b2(1)*(Tr/1.e4)**c2(1) + b2(2)*(Tr/1.e4)**c2(2))*
     &   exp(-227./Tr)

!	Hot-Hot reaction rates
	  Tr=(TOHot+TnHot)/2.
	  khothot=b1(1)*(Tr/1.e4)**c1(1) + b1(2)*(Tr/1.e4)**c1(2)

	  return
	  end


 Module DerivativesEffPotFunctions
 ! ###############################
 ! derivatives of EffPot Functions
 ! ###############################
 Use Control
 Use Mathematics
 Use EffPotFunctions

 Real(dp), parameter :: MIN_MASS_REL = 0.001

 ! totally symmetric functions:
 ! SSS
 ! FFSbar = 2I(x,y,z)
 ! FFVbar = 6I(x,y,z)
 ! VS = 3J(x,y)
 ! SS = J(x,y)
 ! gauge

 ! symmetric in first two arguments
 ! FFS
 ! FFV
 ! SSV
 ! VVS

Contains

Complex(dp) Function deltaPS(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
! Real(dp), Intent(in) :: Q2
deltaPS = (x**2 + y**2 + z**2 - 2*x*y - 2*x*z - 2*y*z)
End Function deltaPS

Complex(dp) Function  phiPS(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: temp1,temp2

If ((Abs(x).le.Abs(y)).and.(Abs(y).le.Abs(z))) Then
 phiPS =  phiNN(y,x,z)
Else if  ((Abs(y).lt.Abs(x)).and.(Abs(x).lt.Abs(z))) Then
 phiPS =  phiNN(x,y,z)
Else if  ((Abs(z).le.Abs(y)).and.(Abs(y).le.Abs(x))) Then
 phiPS =  z/x*phiNN(z,y,x)
Else if  ((Abs(y).le.Abs(z)).and.(Abs(z).le.Abs(x))) Then
 phiPS = phiNN(x,y,z)
Else if ((Abs(x).le.Abs(z)).and.(Abs(z).le.Abs(y))) Then
 phiPS =  y/z*phiNN(x,z,y)
 phiPS = phiNN(x,y,z)
Else if ((Abs(z).le.Abs(x)).and.(Abs(x).le.Abs(y))) Then
 phiPS =  y/z*phiNN(z,x,y)
 phiPS = phiNN(x,y,z)
Else
 Write(*,*) "unknown order",x,y,z
End if

End Function phiPS

Complex(dp) Function  phiNN(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z

phiNN = (Pi**2 - 6._dp*PolyLog(2,(x - y + z - &
     & z*ZSqrt(((x - y)**2 - &
     & 2._dp*(x + y)*z + z**2)/z**2))/(2._dp*z)) - &
     &    6._dp*PolyLog(2,(-x + y + z - z*ZSqrt((x**2 + (y - z)**2 &
     &- 2._dp*x*(y + z))/z**2))/(2._dp*z)) - 3._dp*ZLog(x/z)*ZLog(y/z) + &
     &    6._dp*ZLog((x - y + z - z*ZSqrt((x**2 + (y - z)**2 &
     & - 2._dp*x*(y + z))/z**2))/(2._dp*z))*&
     &     ZLog((-x + y + z - z*ZSqrt((x**2 + (y - z)**2 &
     & - 2._dp*x*(y + z))/z**2))/(2._dp*z)))/(3._dp*Sqrt((x**2 + &
     & (y - z)**2 - 2._dp*x*(y + z))/z**2))

End Function phiNN

! if function is totally symmetric
Subroutine CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(func,m1in,m2in,m3in,Q2,dfunc)
Implicit None
Complex(dp), External :: func
Real(dp), Intent(in) :: m1in,m2in,m3in,Q2
Complex(dp), Intent(out) :: dfunc(3)
Complex(dp) :: m1,m2,m3
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
m3 = Cmplx(m3in,0.,dp)
dfunc(1) = func(m1,m2,m3,Q2)
dfunc(2) = func(m2,m3,m1,Q2)
dfunc(3) = func(m3,m1,m2,Q2)
End Subroutine CalcLoopFunctionFirstDerivativesArrays_sunrise_sym

! if function is symmetric in first two arguments only
Subroutine CalcLoopFunctionFirstDerivativesArrays_sunrise(func1,func3,m1in,m2in,m3in,Q2,dfunc)
Implicit None
Complex(dp), External :: func1, func3
Real(dp), Intent(in) :: m1in,m2in,m3in,Q2
Complex(dp), Intent(out) :: dfunc(3)
Complex(dp) :: m1,m2,m3
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
m3 = Cmplx(m3in,0.,dp)
dfunc(1) = func1(m1,m2,m3,Q2)
dfunc(2) = func1(m2,m1,m3,Q2)
dfunc(3) = func3(m1,m2,m3,Q2)
End Subroutine CalcLoopFunctionFirstDerivativesArrays_sunrise

! if function is only symmetric in m1,m2
Subroutine CalcLoopFunctionSecondDerivativesArrays_sunrise(func11,func33,func12,func13,m1in,m2in,m3in,Q2,ddfunc)
Implicit None
Complex(dp), External :: func11, func33, func12, func13
Real(dp), Intent(in) :: m1in,m2in,m3in,Q2
Complex(dp), Intent(out) :: ddfunc(3,3)
Complex(dp) :: m1,m2,m3
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
m3 = Cmplx(m3in,0.,dp)
ddfunc(1,1) = func11(m1,m2,m3,Q2)
ddfunc(2,2) = func11(m2,m1,m3,Q2)
ddfunc(3,3) = func33(m1,m2,m3,Q2)
ddfunc(1,2) = func12(m1,m2,m3,Q2)
ddfunc(1,3) = func13(m1,m2,m3,Q2)
ddfunc(2,3) = func13(m2,m1,m3,Q2)
ddfunc(2,1) = ddfunc(1,2)
ddfunc(3,1) = ddfunc(1,3)
ddfunc(3,2) = ddfunc(2,3)
End Subroutine CalcLoopFunctionSecondDerivativesArrays_sunrise

Subroutine CalcLoopFunctionSecondDerivativesArrays_sunrise_sym(func11,func12,m1in,m2in,m3in,Q2,ddfunc)
Implicit None
Complex(dp), External :: func11, func12
Real(dp), Intent(in) :: m1in,m2in,m3in,Q2
Complex(dp), Intent(out) :: ddfunc(3,3)
Complex(dp) :: m1,m2,m3
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
m3 = Cmplx(m3in,0.,dp)
ddfunc(1,1) = func11(m1,m2,m3,Q2)
ddfunc(2,2) = func11(m2,m1,m3,Q2)
ddfunc(3,3) = func11(m3,m2,m1,Q2)
ddfunc(1,2) = func12(m1,m2,m3,Q2)
ddfunc(1,3) = func12(m1,m3,m2,Q2)
ddfunc(2,3) = func12(m2,m3,m1,Q2)
ddfunc(2,1) = ddfunc(1,2)
ddfunc(3,1) = ddfunc(1,3)
ddfunc(3,2) = ddfunc(2,3)
End Subroutine CalcLoopFunctionSecondDerivativesArrays_sunrise_sym

! if function is totally symmetric (always the case for balls topology)
Subroutine CalcLoopFunctionFirstDerivativesArrays_balls(func,m1in,m2in,Q2,dfunc)
Implicit None
Complex(dp), External :: func
Real(dp), Intent(in) :: m1in,m2in,Q2
Complex(dp), Intent(out) :: dfunc(2)
Complex(dp) :: m1,m2
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
dfunc(1) = func(m1,m2,Q2)
dfunc(2) = func(m2,m1,Q2)
End Subroutine CalcLoopFunctionFirstDerivativesArrays_balls

! if function is totally symmetric
Subroutine CalcLoopFunctionSecondDerivativesArrays_balls(func11,func12,m1in,m2in,Q2,ddfunc)
Implicit None
Complex(dp), External :: func11, func12
Real(dp), Intent(in) :: m1in,m2in,Q2
Complex(dp), Intent(out) :: ddfunc(2,2)
Complex(dp) :: m1,m2
m1 = Cmplx(m1in,0.,dp)
m2 = Cmplx(m2in,0.,dp)
ddfunc(1,1) = func11(m1,m2,Q2)
ddfunc(2,2) = func11(m2,m1,Q2)
ddfunc(1,2) = func12(m1,m2,Q2)
ddfunc(2,1) = ddfunc(1,2)
End Subroutine CalcLoopFunctionSecondDerivativesArrays_balls

! calculates First and Second derivatives of sunrise diagram contribution
Subroutine SecondDerivativeVeff_sunrise(m1,m2,m3,dm1_i,dm2_i,dm3_i,dm1_j,dm2_j,dm3_j,ddm1,ddm2,ddm3,coup,dcoup_i,dcoup_j,&
&ddcoup,functype,Q2,ddVeff,dVeff_i,dVeff_j)
Implicit None
Real(dp), Intent(in) :: m1,m2,m3,Q2
Complex(dp), Intent(in) :: dm1_i,dm2_i,dm3_i,dm1_j,dm2_j,dm3_j,ddm1,ddm2,ddm3
Complex(dp), Intent(in) :: coup,dcoup_i,dcoup_j,ddcoup
Complex(dp), Intent(out) :: dVeff_i,dVeff_j,ddVeff
Character (Len=6), Intent(in) :: functype
Complex(dp) :: dfunc(3),ddfunc(3,3),Floop
Complex(dp) :: dfunc_vev_i,dfunc_vev_j,ddfunc_vev_ij !  derivatives of floop w.r.t. vevs vi,vj
Integer :: k,l
Complex(dp) :: dm_i(3),dm_j(3),ddm(3),mass1,mass2,dmass1_i,dmass1_j,dmass2_i,dmass2_j,massx,dmassx_i,dmassx_j,ddmassx
Complex(dp) :: ddmass1,ddmass2
dfunc = ZeroC
ddfunc = ZeroC
ddVeff = ZeroC
dVeff_i = ZeroC
dVeff_j = ZeroC
mass1 = sqrt(m1)
mass2 = sqrt(m2)
dm_i = (/dm1_i,dm2_i,dm3_i/)
dm_j = (/dm1_j,dm2_j,dm3_j/)
ddm  = (/ddm1,ddm2,ddm3/)
Select case (functype)
  case('FFS   ')
    Floop = Fep_FFS(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dFFS_1,dFFS_3,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise(ddFFS_11,ddFFS_33,ddFFS_12,ddFFS_13,m1,m2,m3,Q2,ddfunc)
!   Write(*,*) "dd", ddfunc(3,3)
  case('FFSbar')
    Floop = Fep_FFSbar(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise_sym(ddFFSbar_11,ddFFSbar_12,m1,m2,m3,Q2,ddfunc)
!   Write(*,*) "ddb", ddfunc(3,3)
  case('SSS   ')
    Floop = Fep_SSS(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dSSS_1,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise_sym(ddSSS_11,ddSSS_12,m1,m2,m3,Q2,ddfunc)
  case('FFV   ')
    Floop = Fep_FFV(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dFFV_1,dFFV_3,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise(ddFFV_11,ddFFV_33,ddFFV_12,ddFFV_13,m1,m2,m3,Q2,ddfunc)
  case('FFVbar')
    Floop = Fep_FFVbar(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFVbar_1,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise_sym(ddFFVbar_11,ddFFVbar_12,m1,m2,m3,Q2,ddfunc)
  case('SSV   ')
    Floop = Fep_SSV(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dSSV_1,dSSV_3,m1,m2,m3,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_sunrise(ddSSV_11,ddSSV_33,ddSSV_12,ddSSV_13,m1,m2,m3,Q2,ddfunc)
  case('VVS   ')
    Floop = Fep_VVS(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dVVS_1,dVVS_3,m1,m2,m3,Q2,dfunc)
!     Call CalcLoopFunctionSecondDerivativesArrays_sunrise(ddVVS_11,ddVVS_33,ddVVS_12,ddVVS_13,m1,m2,m3,Q2,ddfunc)
  case('gauge ')
    Floop = Fep_gauge(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
!     Call CalcLoopFunctionSecondDerivativesArrays_sunrise_sym(ddfgauge_11,ddfgauge_12,m1,m2,m3,Q2,ddfunc)
  case default
    write(*,*) "unspecified diagram type"
end select

dfunc_vev_i = (dfunc(1)*dm1_i + dfunc(2)*dm2_i + dfunc(3)*dm3_i)
dfunc_vev_j = (dfunc(1)*dm1_j + dfunc(2)*dm2_j + dfunc(3)*dm3_j)
ddfunc_vev_ij = ZeroC
Do k=1,3
  Do l=1,3
    ddfunc_vev_ij = ddfunc_vev_ij + ddfunc(k,l)*dm_i(k)*dm_j(l)
  End Do
  ddfunc_vev_ij = ddfunc_vev_ij + dfunc(k)*ddm(k)
End Do

! in case of FFS/FFSbar/FFV/FFVbar/SSV the case m1=m2 m3=0 can occur
!! NO LONGER NECESSARY AND DISABLED
If (SmallD(m1,m2).and.VerySmallM(m3,m1,m2,Q2).and.(.false.)) then
  ! assuming dm1=dm2, ddm1=ddm2
   Select case (functype)
     case('FFS   ')
       dfunc(1) = dFFS_equalzero(Cmplx(m1,0.,dp),Q2)
       ddfunc(1,1) = ddFFS_equalzero(Cmplx(m1,0.,dp),Q2)
       dfunc_vev_i = dfunc(1)*dm1_i + dfunc(3)*dm3_i
       dfunc_vev_j = dfunc(1)*dm1_j + dfunc(3)*dm3_j
       ddfunc_vev_ij = ddfunc(1,1)*dm1_i*dm1_j + dfunc(1)*ddm1
     case('FFSbar')
       dfunc(1) = dFFSbar_equalzero(Cmplx(m1,0.,dp),Q2)
       ddfunc(1,1) = ddFFSbar_equalzero(Cmplx(m1,0.,dp),Q2)
       dfunc_vev_i = dfunc(1)*dm1_i
       dfunc_vev_j = dfunc(1)*dm1_j
       ddfunc_vev_ij = ddfunc(1,1)*dm1_i*dm1_j + dfunc(1)*ddm1
     case('FFV   ')
       dfunc(1) = dFFV_equalzero(Cmplx(m1,0.,dp),Q2)
       ddfunc(1,1) = ddFFV_equalzero(Cmplx(m1,0.,dp),Q2)
       dfunc_vev_i = dfunc(1)*dm1_i
       dfunc_vev_j = dfunc(1)*dm1_j
       ddfunc_vev_ij = ddfunc(1,1)*dm1_i*dm1_j !+ dfunc(1)*ddm1
     case('FFVbar')
       dfunc(1) = dFFVbar_equalzero(Cmplx(m1,0.,dp),Q2)
       ddfunc(1,1) = ddFFVbar_equalzero(Cmplx(m1,0.,dp),Q2)
       dfunc_vev_i = dfunc(1)*dm1_i
       dfunc_vev_j = dfunc(1)*dm1_j
       ddfunc_vev_ij = ddfunc(1,1)*dm1_i*dm1_j !+ dfunc(1)*ddm1
     case('SSV   ')
       dfunc(1) = dSSV_equalzero(Cmplx(m1,0.,dp),Q2)
       ddfunc(1,1) = ddSSV_equalzero(Cmplx(m1,0.,dp),Q2)
       dfunc_vev_i = dfunc(1)*dm1_i
       dfunc_vev_j = dfunc(1)*dm1_j
       ddfunc_vev_ij = ddfunc(1,1)*dm1_i*dm1_j + dfunc(1)*ddm1
   end select

end if

! derivatives of mass product
! V = coup * mass1 * mass2 * fLoop
If ((functype.eq."FFSbar").or.(functype.eq."FFVbar")) Then

 mass1 = sqrt(m1) ! not-squared masses
 mass2 = sqrt(m2)
 If (mass1.ne.ZeroC) Then
  dmass1_i = dm1_i/(2*mass1) ! derivatives of not-squared masses
  dmass1_j = dm1_j/(2*mass1)
  ddmass1 = - dm1_j*dm1_i/(4._dp*mass1**3) + ddm1/(2._dp*mass1)
 Else
  dmass1_i = 0._dp
  dmass1_j = 0._dp
  ddmass1 = 0._dp
 End If
 If (mass2.ne.ZeroC) Then
  dmass2_i = dm2_i/(2*mass2)
  dmass2_j = dm2_j/(2*mass2)
  ddmass2 = - dm2_j*dm2_i/(4._dp*mass2**3) + ddm2/(2._dp*mass2)
 Else
  dmass2_i = 0._dp
  dmass2_j = 0._dp
  ddmass2 = 0._dp
 End If
 massx = mass1*mass2
 dmassx_i = dmass1_i*mass2 + mass1*dmass2_i ! first derivative
 dmassx_j = dmass1_j*mass2 + mass1*dmass2_j
 ddmassx = ddmass1*mass2 + mass1*ddmass2 + dmass1_i*dmass2_j + dmass1_j*dmass2_i ! second der.

 dVeff_i = dcoup_i*massx*Floop &
 & + coup*dmassx_i*Floop &
 & + coup*massx*dfunc_vev_i

 dVeff_j = dcoup_j*massx*Floop &
 & + coup*dmassx_j*Floop &
 & + coup*massx*dfunc_vev_j

 ddVeff = ddcoup*massx*Floop &
 & + coup*ddmassx*Floop &
 & + coup*massx*ddfunc_vev_ij &
 & + (dcoup_i*dmassx_j + dcoup_j*dmassx_i)*Floop &
 & + (dcoup_i*massx + coup*dmassx_i)*dfunc_vev_j &
 & + (dcoup_j*massx + coup*dmassx_j)*dfunc_vev_i

Else

! V = coup * Floop
 dVeff_i = dcoup_i*Floop + coup*dfunc_vev_i

 dVeff_j = dcoup_j*Floop + coup*dfunc_vev_j

 ddVeff = ddcoup*Floop + coup*ddfunc_vev_ij &
 & + dcoup_i*dfunc_vev_j + dcoup_j*dfunc_vev_i
End If

End Subroutine SecondDerivativeVeff_sunrise

Subroutine SecondDerivativeVeff_balls(m1,m2,dm1_i,dm2_i,dm1_j,dm2_j,ddm1,ddm2,coup,dcoup_i,dcoup_j,ddcoup,functype,Q2,&
&ddVeff,dVeff_i,dVeff_j)
Implicit None
Real(dp), Intent(in) :: m1,m2, Q2
Complex(dp), Intent(in) :: coup,dcoup_i,dcoup_j,ddcoup,dm1_i,dm2_i,dm1_j,dm2_j,ddm1,ddm2
Complex(dp), Intent(out) :: ddVeff,dVeff_i,dVeff_j
Character (Len=2), Intent(in) :: functype
Complex(dp) :: dfunc(2),ddfunc(2,2),Floop
Complex(dp) :: dfunc_vev_i,dfunc_vev_j,ddfunc_vev_ij
Integer :: k,l
Complex(dp) :: dm_i(2),dm_j(2),ddm(2)
dfunc = ZeroC
ddVeff = ZeroC
dVeff_i = ZeroC
dVeff_j = ZeroC
dm_i = (/dm1_i,dm2_i/)
dm_j = (/dm1_j,dm2_j/)
ddm  = (/ddm1,ddm2/)
Select case (functype)
  case('SS')
    Floop = Fep_SS(m1,m2,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_balls(dSS_1,m1,m2,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_balls(ddSS_11,ddSS_12,m1,m2,Q2,ddfunc)
  case('VS')
    Floop = Fep_VS(m1,m2,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_balls(dVS_1,m1,m2,Q2,dfunc)
    Call CalcLoopFunctionSecondDerivativesArrays_balls(ddVS_11,ddVS_12,m1,m2,Q2,ddfunc)
  case default
    write(*,*) "unspecified diagram type"
end select

dfunc_vev_i = (dfunc(1)*dm1_i + dfunc(2)*dm2_i)
dfunc_vev_j = (dfunc(1)*dm1_j + dfunc(2)*dm2_j)
ddfunc_vev_ij = ZeroC
Do k=1,2
  Do l=1,2
    ddfunc_vev_ij = ddfunc_vev_ij + ddfunc(k,l)*dm_i(k)*dm_j(l)
  End Do
  ddfunc_vev_ij = ddfunc_vev_ij + dfunc(k)*ddm(k)
End Do

ddVeff = ddcoup * Floop + coup * ddfunc_vev_ij &
& + dcoup_i * dfunc_vev_j + dcoup_j * dfunc_vev_i

! calculate dVeff too, because all the parts are already there
dVeff_i = (dcoup_i*Floop + coup*dfunc_vev_i)
dVeff_j = (dcoup_j*Floop + coup*dfunc_vev_j)
End Subroutine SecondDerivativeVeff_balls

Subroutine FirstDerivativeVeff_sunrise(m1,m2,m3,dm1,dm2,dm3,coup,dcoup,functype,Q2,dVeff)
Implicit None
Real(dp), Intent(in) :: m1,m2,m3, Q2
Complex(dp), Intent(in) :: coup,dcoup,dm1,dm2,dm3
Complex(dp), Intent(out) :: dVeff
Character (Len=6), Intent(in) :: functype
Complex(dp) :: dfunc(3),Floop,dFloop,dmass1,dmass2,mass1,mass2
dVeff = ZeroC
dfunc = ZeroC
mass1 = ZeroC
mass2 = ZeroC
Select case (functype)
  case('FFS   ')
    Floop = Fep_FFS(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dFFS_1,dFFS_3,m1,m2,m3,Q2,dfunc)
  case('FFSbar')
    Floop = Fep_FFSbar(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
  case('SSS   ')
    Floop = Fep_SSS(m1,m2,m3,Q2)
    Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
  case('FFV   ')
    Floop = Fep_FFV(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dFFV_1,dFFV_3,m1,m2,m3,Q2,dfunc)
  case('FFVbar')
    Floop = Fep_FFVbar(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
  case('SSV   ')
    Floop = Fep_SSV(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dSSV_1,dSSV_3,m1,m2,m3,Q2,dfunc)
  case('VVS   ')
    Floop = Fep_VVS(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise(dVVS_1,dVVS_3,m1,m2,m3,Q2,dfunc)
  case('gauge ')
    Floop = Fep_gauge(m1,m2,m3,Q2)
!     Call CalcLoopFunctionFirstDerivativesArrays_sunrise_sym(dFFSbar_1,m1,m2,m3,Q2,dfunc)
  case default
    write(*,*) "unspecified diagram type"
end select

dFloop = (dfunc(1)*dm1+dfunc(2)*dm2+dfunc(3)*dm3)
dVeff = dcoup * Floop + coup * dFloop ! product rule

! V = coup * mass1 * mass2 * fLoop
If ((functype.eq."FFSbar").or.(functype.eq."FFVbar")) Then
 If (mass1.ne.ZeroC) Then
  mass1 = sqrt(m1)
  dmass1 = dm1/(2*mass1)
 End If
 If (mass2.ne.ZeroC) Then
  mass2 = sqrt(m2)
  dmass2 = dm2/(2*mass2)
 End If
 dVeff = dcoup* mass1*mass2*Floop &
 & + coup * (dmass1*mass2+mass1*dmass2) * Floop &
 & + coup * mass1*mass2 * dFloop
End If

End Subroutine FirstDerivativeVeff_sunrise

Subroutine FirstDerivativeVeff_balls(m1,m2,dm1,dm2,coup,dcoup,functype,Q2,dVeff)
Implicit None
Real(dp), Intent(in) :: m1,m2,Q2
Complex(dp), Intent(in) :: coup,dcoup,dm1,dm2
Complex(dp), Intent(out) :: dVeff
Character (Len=2), Intent(in) :: functype
Complex(dp) :: dfunc(2),Floop
dfunc = ZeroC
dVeff = ZeroC
Select case (functype)
  case('SS')
    Floop = Fep_SS(m1,m2,Q2)
    dfunc(1) = dSS_1(m1,m2,Q2)
    dfunc(2) = dSS_1(m2,m1,Q2) ! symmetric in m1,m2
  case('VS')
    Floop = Fep_VS(m1,m2,Q2)
    dfunc(1) = dVS_1(m1,m2,Q2)
    dfunc(2) = dVS_1(m2,m1,Q2) ! symmetric in m1,m2
  case default
    write(*,*) "unspecified diagram type"
end select

dVeff = dcoup * Floop + &
& coup * (dfunc(1)*dm1+dfunc(2)*dm2)
End Subroutine FirstDerivativeVeff_balls

Complex(dp) Function PolyLog(n,z)
Implicit None
Integer, Intent(in) :: n
Complex(dp), Intent(in) :: z
If (n.eq.2) Then
PolyLog = CLI2_mod(z)
Else
PolyLog = ZeroC
write(*,*) 'PolyLog(n,z) for n>2 not implemented!'
End If
End Function PolyLog

! #######################
! ####### FFS
! #######################

! derivatives created by Wolfram Mathematica 9

! 1st derivative, 1st argument (x)
Complex(dp) Function dFFS_1(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

dFFS_1 = dJ2x_1(x,y,Q2) - dJ2x_1(x,z,Q2) + I_SMartinC(x,y,z,Q2) &
& + (x+y-z)*dI_1(x,y,z,Q2)
If (dFFS_1.ne.dFFS_1) then
  write(*,*) "NaN appearing in dFFS_1"
End if
End Function

! 1st derivative, 3rd argument (z)
Complex(dp) Function dFFS_3(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

dFFS_3 = -dJ2x_1(z,x,Q2) - dJ2x_1(z,y,Q2) - I_SMartinC(x,y,z,Q2) &
& + (x+y-z)*dI_1(z,x,y,Q2)
If (dFFS_3.ne.dFFS_3) then
!   write(*,*) "NaN appearing in dFFS_3"
End if

End Function dFFS_3

! 2nd derivative, arguments (x,x)
Complex(dp) Function ddFFS_11(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

ddFFS_11 = ddJ2x_11(x,y,Q2)-ddJ2x_11(x,z,Q2)+2*dI_1(x,y,z,Q2)+(x+y-z)*ddI_11(x,y,z,Q2)
If (ddFFS_11.ne.ddFFS_11) then
!   write(*,*) "NaN appearing in ddFFS_11"
End if

End Function ddFFS_11

! 2nd derivative, arguments (z,z)
Complex(dp) Function ddFFS_33(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

ddFFS_33 = -ddJ2x_11(z,x,Q2)-ddJ2x_11(z,y,Q2)-2*dI_1(z,x,y,Q2)+(x+y-z)*ddI_11(z,x,y,Q2)
! If (abs(ddFFS_33).gt.100000._dp) Write(*,*) "33", ddFFS_33, (x+y-z)*ddI_11(z,x,y,Q2)
If (ddFFS_33.ne.ddFFS_33) then
!   write(*,*) "NaN appearing in ddFFS_33"
End if

End Function ddFFS_33

! 2nd derivative, arguments (x,y)
Complex(dp) Function ddFFS_12(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

ddFFS_12 = ddJ2x_12(x,y,Q2) + dI_1(y,x,z,Q2) + dI_1(x,y,z,Q2) + (x+y-z)*ddI_12(x,y,z,Q2)
If (ddFFS_12.ne.ddFFS_12) then
!   write(*,*) "NaN appearing in ddFFS_12"
End if
End Function ddFFS_12

! 2nd derivative, arguments (x,z)
Complex(dp) Function ddFFS_13(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

ddFFS_13 = -ddJ2x_12(x,z,Q2)+dI_1(z,x,y,Q2)-dI_1(x,y,z,Q2)+(x+y-z)*ddI_12(x,z,y,Q2)
If (ddFFS_13.ne.ddFFS_13) then
!   write(*,*) "NaN appearing in ddFFS_13"
End if
End Function ddFFS_13

! #######################
! ####### FFV
! #######################

! for special case m1=m2 and m3=0 only !!!
Complex(dp) function dFFV_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x
x = xin
If (VerySmallM(Real(xin,dp),Q2)) then
  dFFV_equalzero = ZeroC
else
  dFFV_equalzero = -4._dp*x+8._dp*x*(-1._dp+ZLOG(x/Q2))
end if
end function dFFV_equalzero

! for special case m1=m2 and m3=0 only !!!
Complex(dp) function ddFFV_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x
x = xin
If (VerySmallM(Real(xin,dp),Q2)) then
  ddFFV_equalzero = ZeroC
else
  ddFFV_equalzero = 4._dp+8._dp*(-1._dp+ZLOG(x/Q2))
end if
end function ddFFV_equalzero

Complex(dp) Function dFFV_1(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) Then ! f_x(x,y,0)
  If (VerySmallM(x,y,z,Q2)) Then ! f_x(0,y,0)
    res = ZeroC
  Else ! f_x(x,y,0)
    res = 2._dp*x-2._dp*(x+y)+4._dp*x*(-1._dp+ZLog(x/Q2))
  end if
Else ! z!=0
  If (SmallD(x,y)) then ! f_x(x,x,0)
    res = (z*I_SMartinC(x,x,z,Q2)+z*(-((2*z+x*ZLOG(x/Q2))*(-1+ZLOG(z/Q2)))+ZLOG(x/Q2)*(-&
    &3*x+2*z+2*x*ZLOG(x/Q2)+(x-2*z)*ZLOG(z/Q2)))+(2*x*z-2*z**2)*dI_1(x,x,z,Q2))/z
  else
    ! f_x(x,y,0)
    res = (2*(-x+y)*I_SMartinC(x,y,ZeroC,Q2)+(2*x-2*y+z)*I_SMartinC(x,y,&
    &z,Q2)+z*(-((x-y+2*z+&
    &y*ZLOG(y/Q2))*(-1+ZLOG(z/Q2)))+ZLOG(x/Q2)*(-2*x-y+2*z+2*y*ZLOG(y/Q2)&
    &+(2*x-y-2*z)*ZLOG(z/Q2)))-(x-y)**2*dI_1(x,y,ZeroC,Q2)&
    &+((x-y)**2+(x+y)*z-2*z**2)*dI_1(x,y,z,Q2))/z
  end if
End if
If (res.ne.res) write(*,*) "NaN appearing in dFFV_1 for input ",Real(x),Real(y),Real(z)
dFFV_1 = res
End Function dFFV_1

Complex(dp) Function dFFV_3(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin
Call SortTwoArgumentsC(x,y)
If (VerySmallM(zin,xin,yin,Q2)) Then ! f_z(x,y,0)
  If (VerySmallM(x,y,z,Q2)) Then ! f_z(0,y,0)
    res = ZeroC
  Else ! f_z(x,y,0)
    res = ZeroC
  end if
Else ! z!=0
  If (SmallD(x,y)) then ! f_x(x,x,z)
    res = (z*I_SMartinC(x,x,z,Q2)+z*(-((2*z+x*ZLOG(x/Q2))*(-1+ZLOG(z/Q2)))+ZLOG(x/Q2)*(-&
    &3*x+2*z+2*x*ZLOG(x/Q2)+(x-2*z)*ZLOG(z/Q2)))+(2*x*z-2*z**2)*dI_1(x,x,z,Q2))/z
  else
    ! f_z(x,y,z)
    res = (3*(x-y)**2*I_SMartinC(x,y,ZeroC,Q2)-3*((x-y)**2+2*z**2)*I_SMartinC(x,y,z,Q2)+z*(-3*(x-&
    &y)**2-2*z**2+4*z**2*ZLOG(z/Q2)+3*x*ZLOG(x/Q2)*(x-y-2*z*ZLOG(z/Q2))&
    &+3*y*ZLOG(y/Q2)*(-x+y-2*z*ZLOG(z/Q2))+3*((x-y)**2+(x+y)*z-2*z**2)&
    &*dI_1(z,x,y,Q2)))/(3.*z**2)
  end if
End if
If (res.ne.res) write(*,*) "NaN appearing in dFFV_3 for input ",Real(x),Real(y),Real(z)
dFFV_3 = res
End Function dFFV_3

Complex(dp) Function ddFFV_11(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(zin,x,y,Q2)) Then ! f_xx(x,y,0)
  If (VerySmallM(x,y,z,Q2)) Then ! f_xx(0,y,0)
    res = ZeroC
  Else ! f_xx(x,y,0)
    res = 4._dp*ZLOG(x/Q2)
  end if
Else
    ! f_xx(x,y,z)
    res = (-2*x*I_SMartinC(x,y,ZeroC,Q2)+2*x*I_SMartinC(x,y,z,Q2)+z*(-x-y+2*z+2*y*&
    &ZLOG(y/Q2)+2*x*ZLOG(x/Q2)&
    &*(-1+ZLOG(z/Q2))+(x-y-2*z)*ZLOG(z/Q2))+x*(4*(-x+y)*I_SMartinC(x,y,ZeroC,Q2)&
    &+2*(2*x-2*y+z)*I_SMartinC(x,y,z,Q2)-(x-y)&
    &**2*ddI_11(x,y,ZeroC,Q2)+((x-y)**2+(x+y)*z-2*z**2)*ddI_11(x,y,z,Q2)))/(x*z)
End if
If (res.ne.res) write(*,*) "NaN appearing in ddFFV_11 for input ",Real(x),Real(y),Real(z)
ddFFV_11 = res
End Function ddFFV_11

Complex(dp) Function ddFFV_33(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin
Call SortTwoArgumentsC(y,z)
If (VerySmallM(y,x,z,Q2)) Then ! f_zz(x,y,0)
  If (VerySmallM(x,y,z,Q2)) Then ! f_zz(0,y,0)
!  Write(*,*) 1
    res = ZeroC
  Else ! f_zz(x,y,0)
    res = ZeroC
  end if
Else ! z!=0
  If (SmallD(x,y)) then ! f_zz(x,x,z)
      res = (2*(z-6*x*ZLOG(x/Q2)+2*z*ZLOG(z/Q2)-6*z*dI_1(z,x,x,Q2)&
      &+3*(x-z)*z*ddI_11(z,x,x,Q2)))/(3.*z)
  else
      ! f_zz(x,y,z)
      res = (-6*(x-y)**2*I_SMartinC(x,y,ZeroC,Q2)+6*(x-y)**2*I_SMartinC(x,y,z,Q2)+z*(3*(x-y)**2+2*z**2-&
      &3*x*(x-y+2*z)*ZLOG(x/Q2)-3*y*(-x+y+2*z)*ZLOG(y/Q2)+4*z**2*ZLOG(z/Q2)&
      &-6*((x-y)**2+2*z**2)*dI_1(z,x,y,Q2)+3*z*((x-y)**2+&
      &(x+y)*z-2*z**2)*ddI_11(z,x,y,Q2)))/(3.*z**3)
  end if
End if
If (res.ne.res) write(*,*) "NaN appearing in ddFFV_33 for input ",Real(x),Real(y),Real(z)
ddFFV_33 = res
End Function ddFFV_33

Complex(dp) Function ddFFV_12(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in):: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin
Call SortTwoArgumentsC(x,y)
If (VerySmallM(zin,x,y,Q2)) Then ! f_xy(x,y,0)
    res = -2._dp
Else ! z!=0
  If (SmallD(x,y)) then ! f_xy(x,x,z)
    res = (2*z+2*I_SMartinC(x,x,ZeroC,Q2)-2*I_SMartinC(x,x,z,Q2)+4*z*(-1+ZLOG(x/Q2))+2*z*(-1+ZLOG(x/Q2))&
    &**2-2*z*(-1+ZLOG(z/Q2))-2*z*(-1+ZLOG(x/Q2))*(-1+ZLOG(z/Q2))+z*&
    &dI_1(x,x,z,Q2)+z*dI_1(x,x,z,Q2)+(2*x**2+x*z-2*z**2+&
    &x*(-2*x+z))*ddI_12(x,x,z,Q2))/z
  else
    ! f_xy(x,y,z)
    res = (2*I_SMartinC(x,y,ZeroC,Q2)-2*I_SMartinC(x,y,z,Q2)+z*(ZLOG(x/Q2)*(1+2*ZLOG(y/Q2)-ZLOG(z/Q2))&
    &-ZLOG(y/Q2)*(-1+ZLOG(z/Q2)))+2*(-x+y)*dI_1(y,x,ZeroC,Q2)&
    &+(2*x-2*y+z)*dI_1(y,x,z,Q2)+2*x*dI_1&
    &(x,y,ZeroC,Q2)-2*y*dI_1(x,y,ZeroC,Q2)-2*x*dI_1(x,&
    &y,z,Q2)+2*y*dI_1(x,y,z,Q2)+z*dI_1(x,y,z,Q2)&
    &-x**2*ddI_12(x,y,ZeroC,Q2)+2*x*y*ddI_12(x,y,zeroC,Q2)&
    &-y**2*ddI_12(x,y,ZeroC,Q2)+((x-y)**2+(x+y)*z-2*z**2)&
    &*ddI_12(x,y,z,Q2))/z
  end if
End if
If (res.ne.res) write(*,*) "NaN appearing in ddFFV_12 for input ",Real(x),Real(y),Real(z)
ddFFV_12 = res
End Function ddFFV_12

Complex(dp) Function ddFFV_13(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in):: x,y,z
Complex(dp) :: res
If (VerySmallM(z,x,y,Q2)) Then
    res = ZeroC
Else ! z!=0
  If (VerySmallM(x,y,z,Q2)) then
    res = ZeroC
  else
    If (VerySmallM(y,x,z,Q2)) then
      res = ZeroC
    else
      ! f_xz(x,y,z)
    res = (2*(x-y)*I_SMartinC(x,y,ZeroC,Q2)+2*(-x+y)*I_SMartinC(x,y,z,Q2)+z*(-x+y-y*ZLOG(y/Q2)-&
    &2*z*ZLOG(z/Q2)+ZLOG(x/Q2)*(2*x-y-2*z*ZLOG(z/Q2)))+2*x*z*&
    &dI_1(z,x,y,Q2)-2*y*z*dI_1(z,x,y,Q2)+z**2*&
    &dI_1(z,x,y,Q2)+x**2*dI_1(x,y,ZeroC,Q2)-2*x*y*&
    &dI_1(x,y,ZeroC,Q2)+y**2*dI_1(x,y,ZeroC,Q2)-x**2*&
    &dI_1(x,y,z,Q2)+2*x*y*dI_1(x,y,z,Q2)-y**2*&
    &dI_1(x,y,z,Q2)-2*z**2*dI_1(x,y,z,Q2)+z*((x-y)**2+(x+&
    &y)*z-2*z**2)*ddI_12(x,z,y,Q2))/z**2
    end if
  end if
End if
If (res.ne.res) write(*,*) "NaN appearing in ddFFV_13 for input ",Real(x),Real(y),Real(z)
ddFFV_13 = res
End Function ddFFV_13

! #######################
! ####### SSV
! #######################

Complex(dp) Function dSSV_equalzero(xin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin
Complex(dp) :: res,x
x = xin

res = 6*I_SMartinC(x,x,ZeroC,Q2)+3*dJ2x_1(x,x,Q2)+3*dJ2x_1(x,x,Q2)+&
&2*x*(6-4*ZLOG(x/Q2)+3*dI_1(x,x,ZeroC,Q2)+3*&
&dI_1(x,x,ZeroC,Q2))

dSSV_equalzero = res
end function dSSV_equalzero

Complex(dp) Function ddSSV_equalzero(xin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin
Complex(dp) :: res,x
x = xin

res = 4._dp-8._dp*ZLOG(x/Q2)+3*(ddJ2x_11(x,x,Q2)+2*ddJ2x_12(x,x,Q2)&
 &+ddJ2x_11(x,x,Q2))+12*(dI_1(x,x,ZeroC,Q2)+&
&dI_1(x,x,ZeroC,Q2))+6*x*(ddI_11(x,x,ZeroC,Q2)+2*&
&ddI_12(x,x,ZeroC,Q2)+ddI_11(x,x,ZeroC,Q2))

res = 8 + 12*dI_equalzero(x,Q2) + 6*x*ddI_equalzero(x,Q2) &
    & + 6*dJ(x,Q2)**2 + 6*J_SMartinC(x,Q2)*ddJ(x,Q2) - 8*dJ(x,Q2) - 4*x*ddJ(x,Q2)

ddSSV_equalzero = res
end function ddSSV_equalzero

Complex(dp) Function dSSV_1(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = 4*x+2*y+3*I_SMartinC(x,y,ZeroC,Q2)-4*x*ZLOG(x/Q2)+3*dJ2x_1(x,y,Q2)+3*(x+&
    &y)*dI_1(x,y,ZeroC,Q2)

else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

dSSV_1 = res
end function dSSV_1

Complex(dp) Function dSSV_3(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = ZeroC

else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

dSSV_3 = res
end function dSSV_3

Complex(dp) Function ddSSV_11(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = -4*ZLOG(x/Q2)+3*ddJ2x_11(x,y,Q2)+6*dI_1(x,y,&
&ZeroC,Q2)+3*(x+y)*ddI_11(x,y,ZeroC,Q2)

else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

ddSSV_11 = res
end function ddSSV_11

Complex(dp) Function ddSSV_33(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = ZeroC
else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

ddSSV_33 = res
end function ddSSV_33

Complex(dp) Function ddSSV_12(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = 2+3*ddJ2x_12(x,y,Q2)+3*dI_1(y,x,ZeroC,Q2)+3*&
&dI_1(x,y,ZeroC,Q2)+3*(x+y)*ddI_12(x,y,ZeroC,Q2)

else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

ddSSV_12 = res
end function ddSSV_12

Complex(dp) Function ddSSV_13(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: xin,yin,zin
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

If (VerySmallM(z,x,y,Q2)) then ! z=0
    res = ZeroC

else ! z not 0
  res = ZeroC
  write(*,*) 'derivative of SSV w. massive vector not implemented!'
end if

ddSSV_13 = res
end function ddSSV_13

! #######################
! ####### VVS
! #######################

! #######################
! ####### gauge / VVV
! #######################

! #######################
! ####### I(x,y,z) derivatives, J(x,y) and J(x)
! #######################

!! symmetric in y,z variables
Complex(dp) Function dI_1(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

Call SortTwoArgumentsC(y,z)
! now y < z (real part)

res = ZeroC
If (VerySmallM(x,y,z,Q2)) Then ! x = 0
 If (SmallD(y,z)) Then  !
   res = 0._dp
 Else If (SmallM(y,x,z,Q2)) Then ! f_x(x,0,a) | x->0
  res = -0.5_dp + Pi**2/6._dp + ZLog(z/Q2)**2/2._dp
 Else ! f_x(x,a,b) | x->0
   res = -((3 + Pi**2)*y + (-3 + Pi**2)*z + 3*(y - z)*(2*Log(1 - y/z) - &
    & Log(y/Q2)*(-1 + Log(z/Q2)) + Log(z/Q2)) - 6*(y + z)*PolyLog(2,y/z))/(6.*(y - z))
! Using II function
  res = -(3._dp*y + Pi**2*y - 3._dp*z + Pi**2*z - 3._dp*(y - z)*zLog(y/Q2)*(-1._dp + zLog(z/Q2)) &
   & + 3._dp*y*zLog(z/Q2) - 3._dp*z*zLog(z/Q2) - 6._dp*(y + z)*PolyLog(2,y/z))/(6._dp*(y - z))
 End If

Else if (SmallM(x,y,z,Q2)) Then ! x small
 If (SmallM(z,x,y,Q2)) Then
  res = 0._dp
 Else If (SmallM(y,x,z,Q2)) Then
  res = (-3._dp + Pi**2 - 6._dp*Log(x/Q2)*(-1._dp + Log(z/Q2)) + 3._dp*Log(z/Q2)**2)/6._dp
 Else
  If (SmallD(y,z)) Then
   res = (3._dp + ZLog(y/Q2)*(2 - 2._dp*ZLog(x/Q2) + ZLog(y/Q2)))/2._dp
  Else
   res = ((-3._dp + Pi**2)*y + (3._dp + Pi**2)*z - 6._dp*(y + z)*PolyLog(2,z/y) &
    &  - 6._dp*ZLog(x)*(-y + z + y*ZLog(y/Q2)) - &
    &  3._dp*(y + z)*(ZLog(y/Q2)**2 - 2._dp*ZLog((y - z)/Q2)*ZLog(y/z)) + &
    & 6._dp*(z*ZLog(x) + y*ZLog(y/Q2))*ZLog(z/Q2))/(6._dp*(y - z))
  End if
 End if

Else  ! x large
  If (SmallM(y,x,z,Q2)) Then
    If (SmallM(z,x,y,Q2)) Then
      ! f_x(x,0,0)
      res = -0.5_dp-Pi**2/6._dp+ZLog(x/Q2)-ZLog(x/Q2)**2/2._dp
    Else If (SmallD(x,z)) then       ! f_1(x,0,x)
        res = -(-1._dp + zLog(x/Q2))**2/2._dp
    else  ! f_x(x,0,z))
        res=-(x - 2*(x + z)*zLog(x/q2) + x*zLog(x/q2)**2 + 2*z*zLog(z/q2) &
           & - 2*z*zLog(z/x) + 2*x*PolyLog(2,1 - z/x))/(2._dp*x)
    End If
  Else
      ! f_x(x,y,z)
      !res = -(x+(x+y-z)*ZLOG(y/Q2)+(x-y+z-x*ZLOG(y/Q2))*ZLOG(z/Q2)+x*ZLOG(x/Q2)&
     ! &*(-4._dp+ZLOG(y/Q2)+ZLOG(z/Q2))+x*dXi_1(x,y,z))/(2._dp*x)

!! NEW FUNCTION BY FS

res = (x*(-x + y + z)*phiPS(x,y,z) - z*(x + x*log(x/y) + &
&x*log(y/Q2) + y*log(y/Q2) - z*log(y/Q2) + x*log(x/z) + &
&x*log(z/Q2) - y*log(z/Q2) + &
&    z*log(z/Q2) - x*log(y/Q2)*log(z/Q2) +&
& x*log(x/Q2)*(-4._dp + log(y/Q2) + log(z/Q2)) + (y - z)*log(z/y)))/(2._dp*x*z)

! If (writeoutscreen) Write(*,*) real(x,dp),Real(y,dp),Real(z,dp), Abs(x/y), Abs(x/z), Abs(y/z)
 End if
End If

If (res.ne.res) write(*,*) "NaN appearing in dI_1 for input ",Real(x),Real(y),Real(z)
dI_1 = res
End Function dI_1

Complex(dp) function ddI_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x
x = xin

If (VerySmallM(Real(xin,dp),Q2)) then
  res = ZeroC
else
   res = (2._dp - 2._dp*ZLOG(x/Q2))/x
end if

ddI_equalzero = res
End function ddI_equalzero

Complex(dp) function dI_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x
x = xin

If (VerySmallM(Real(xin,dp),Q2)) then
  res = ZeroC
else
  res = -1+2*ZLOG(x/Q2)-ZLOG(x/Q2)**2
end if

dI_equalzero = res
End function dI_equalzero

Complex(dp) Function ddI_11(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res,x,y,z
x = xin
y = yin
z = zin

Call SortTwoArgumentsC(y,z)

res = ZeroC
If (VerySmallM(x,y,z,Q2)) Then ! x=0
 If (SmallD(z,y)) Then  ! y=z
  If (SmallM(z,x,y,Q2)) Then ! f_xx(x,0,0) | x->0
    res = 0._dp
  Else ! f_xx(x,a,a) | x->0
    res = 0._dp
  End if
 Else
  If (SmallM(y,x,z,Q2)) Then ! f_xx(x,0,a) | x->0
   res = -2/z + (3*ZLog(z/Q2))/(2._dp*z)
  Else ! f_xx(x,a,b) | x->0
   res=  (-12*y**2 - 4*Pi**2*y*z + 12*z**2 + 24*y*z*PolyLog(2,y/z) + (9*y**2 - &
& 6*y*z - 3*z**2)*ZLog(y/Q2) + 3*y**2*ZLog(z/Q2) + 6*y*z*ZLog(z/Q2) - &
& 9*z**2*ZLog(z/Q2))/(6._dp*(y - z)**3)
  End if
 End if
Else if (SmallM(x,y,z,Q2)) Then ! x small
 If (SmallD(y,z)) then ! y=z
  If (VerySmallM(y,z,z,Q2)) Then ! y=z=0
   res = (1-zlog(x/Q2))/x ! derived from I(0,0,x) (2.28 in hep-ph/0111209)
  else ! y=z not zeroC
   res = -zlog(y/Q2)/x ! derived from (*)
  end if
 else If (VerySmallM(y,z,x,Q2)) Then ! y=0
  res = (1 - zLog(z/Q2))/x ! also derived from (*)
 else ! y != z, both large
  res = (y - z - y*ZLog(y/Q2) + z*ZLog(z/Q2))/(x*(y - z)) ! eq. (*)
 end if
Else
  If (SmallM(y,x,z,Q2)) Then
    If (SmallM(z,x,y,Q2)) Then
      ! f_xx(x,0,0)
      res = (1-zLog(x/Q2))/x
    Else
      If (SmallD(x,z)) then
           res =-(zLog(x/Q2)/x)
      else
	! f_xx (x,0,z)
	res = (1.*x**2-1.*x*z+(1.*x**2-1.*z**2)*Log(x/Q2)+(-1.*x**2+1.*z**2)&
	&*Log((x-1.*z)/Q2)-1.*x**2*Log(x/z)-1.*x**2*Log(z/Q2)+1.*x*z*Log(z/Q2)&
	&+1.*x**2*Log(1.-(1.*z)/x)-1.*z**2*Log(1.-(1.*z)/x))/(x**2*(x-1.*z))
      end if
    End If
  Else
!    res = -(-4._dp*x+(x-y+z)*ZLOG(y/Q2)+(x+y-z)*ZLOG(z/Q2)+x**2._dp*&
!    & ddXi_11(x,y,z))/(2._dp*x**2._dp)

!! NEW FUNCTION BY FS
 res = (x*(x - y - z)*(x*(x - y - z)*phiPS(x,y,z) - x*z*(Zlog(x/y) &
  &  + Zlog(x/z)) + z*(-y + z)*Zlog(z/y)) &
  &   -  deltaPS(x,y,z)*(x**2*phiPS(x,y,z) + &
  & z*(-2._dp*x + (x - y + z)*Zlog(y/Q2) + (x + y - z)*Zlog(z/Q2) + &
 & (-y + z)*Zlog(z/y))))/(2._dp*x**2*z*deltaPS(x,y,z))
  End If
End If
If (res.ne.res) write(*,*) "NaN appearing in ddI_11 for input",Real(x),Real(y),Real(z)
ddI_11 = res
End Function ddI_11

Complex Function ddI_12_0(x,z,Q2)
Complex(dp), Intent(in) :: x,z
Real(dp), Intent(in) :: Q2

If (((Real(x,dp).gt.Real(z,dp)).And.(Real(z,dp).gt.0._dp)).or.((Real(x,dp).lt.Real(z,dp)).And.(Real(z,dp).lt.0._dp))) Then
 ddI_12_0 = (4*x*z*PolyLog(2,1 - x/z) + 2*x*(x + z)*ZLog(x/Q2) - x**2*ZLog(z/Q2) &
- 4*x*z*ZLog(z/Q2) + z**2*ZLog(z/Q2) + x**2*ZLog(z/x) - x*z*ZLog(z/x))/(2._dp*x*(x - z)**2)
Else
  ddI_12_0 =  (2*Pi**2*x*z - 12*x*z*PolyLog(2,x/z) + 6*x*(x + z)*ZLog(x/Q2) - &
&3*x**2*ZLog(z/Q2) - 12*x*z*ZLog(z/Q2) + 3*z**2*ZLog(z/Q2) + &
&3*x**2*ZLog(z/x) - 3*x*z*ZLog(z/x))/(6._dp*x*(x - z)**2)
End if

End Function ddI_12_0

Complex(dp) Function ddI_12(x,y,z,Q2)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q2
Complex(dp) :: res

res = ZeroC
If (SmallM(y,x,z,Q2).or.(SmallM(x,y,z,Q2))) Then
 If (SmallM(x,y,z,Q2)) Then
  If (SmallM(y,x,z,Q2)) Then
   If (SmallM(z,x,y,Q2)) Then
    res = ZeroC
   Else
    res = Pi**2/(3._dp*z) - (2*ZLog(z/Q2))/z
   End If
  Else  ! y > 0
   If (SmallM(z,y,x,Q2)) Then
    res = ZLog(y/Q2)/y
   Else
    If (SmallD(y,z)) Then
     res= 0._dp
    Else
     res= ddI_12_0(y,z,Q2)
    End if
   End if
  End if
 Else !  x > 0
   If (SmallD(x,z)) Then
    res= 0._dp
   Else
   If (SmallM(z,x,y,Q2)) Then
    res =  ZLog(x/Q2)/x
   Else
    res= ddI_12_0(x,z,Q2)
   End if
   End if
 End if
Else
  If (SmallM(z,x,y,Q2)) Then ! z=0
    If (SmallD(x,y)) then  !x=y
           res = 1._dp/x
    else
      ! f_xy(x,y,0)
      res = ((-1.*x**2+1.*y**2)*Log(x/Q2)+(1.*x**2-1.*y**2)*Log((x-1.*y)/Q2)&
      &+1.*x*y*Log(x/y)-1.*x**2*Log(1.-(1.*y)/x)+1.*y**2*Log(1.-(1.*y)&
      &/x))/(x*(x-1.*y)*y)
    end if
  Else ! z > 0
!      res = -(x+y-z+x*ZLOG(x/Q2)+y*ZLOG(y/Q2)-x*ZLOG(z/Q2)-y*ZLOG(z/Q2)+x*y*&
!      &ddXi_12(x,y,z))/(2._dp*x*y)
! !NEW FUNCTION BY FS
      res =  (-(x*(x - y - z)*(y*(x - y + z)*phiPS(x,y,z) &
     & + y*z*(Zlog(y/x) + Zlog(y/z)) + (x - z)*z*Zlog(z/x))) + &
     &    deltaPS(x,y,z)*(x*y*phiPS(x,y,z) &
     & - z*(x*Zlog(x/Q2) + y*Zlog(y/Q2) - (x + y)*Zlog(z/Q2) + y*Zlog(z/y))))/(2._dp*x*y*z*deltaPS(x,y,z))
  End If
End If

  If (res.ne.res) write(*,*) "NaN appearing in ddI_12 for input",Real(x),Real(y),Real(z)
ddI_12 = res
End Function ddI_12

! some functions that only depend on I(x,y,z)
! SSS, FFSbar, FFVbar

Complex(dp) Function dSSS_1(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fSSS(x,y,z) = -I(x,y,z)
res = -dI_1(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in dSSS_1"
dSSS_1 = res
End Function dSSS_1

Complex(dp) Function ddSSS_11(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fSSS(x,y,z) = -I(x,y,z)
res = -ddI_11(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddSSS_11"
ddSSS_11 = res
End Function ddSSS_11

Complex(dp) Function ddSSS_12(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fSSS(x,y,z) = -I(x,y,z)
res = -ddI_12(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddSSS_12"
ddSSS_12 = res
End Function ddSSS_12

Complex(dp) Function dFFSbar_1(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = 2I(x,y,z)
res = 2*dI_1(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in dFFSbar_1"
dFFSbar_1 = res
End Function dFFSbar_1

Complex(dp) Function ddFFSbar_11(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2

Complex(dp) :: res
! fFFSbar(x,y,z) = 2I(x,y,z)
res = 2*ddI_11(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFSbar_11"
ddFFSbar_11 = res
End Function ddFFSbar_11

Complex(dp) Function ddFFSbar_12(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = 2I(x,y,z)
res = 2*ddI_12(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFSbar_12"
ddFFSbar_12 = res
End Function ddFFSbar_12

Complex(dp) Function dFFVbar_1(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFVbar(x,y,z) = 6I(x,y,z)
res = 6*dI_1(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in dFFVbar_1"
dFFVbar_1 = res
End Function dFFVbar_1

Complex(dp) Function ddFFVbar_11(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFVbar(x,y,z) = 6I(x,y,z)
res = 6*ddI_11(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFVbar_11"
ddFFVbar_11 = res
End Function ddFFVbar_11

Complex(dp) Function ddFFVbar_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFVbar(x,y,z) = 6I(x,y,z)
res = 6*ddI_equalzero(xin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFVbar_11"
ddFFVbar_equalzero = res
End Function ddFFVbar_equalzero

Complex(dp) Function dFFVbar_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFVbar(x,y,z) = 6I(x,y,z)
res = 6*dI_equalzero(xin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFVbar_11"
dFFVbar_equalzero = res
End Function dFFVbar_equalzero

Complex(dp) Function ddFFSbar_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = 2I(x,y,z)
res = 2*ddI_equalzero(xin,Q2)
ddFFSbar_equalzero = res
End Function ddFFSbar_equalzero

Complex(dp) Function dFFSbar_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = J(x,x) + 2x*I(x,x,0)
res = 2*dI_equalzero(xin,Q2)
dFFSbar_equalzero = res
End Function dFFSbar_equalzero

Complex(dp) Function ddFFS_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = J(x,x) + 2x*I(x,x,0)
If (VerySmallM(Abs(xin),q2,q2,q2)) Then
 res = 0._dp
Else
 res = -2._dp*(1._dp + (-3._dp + ZLog(xin/Q2))*zLog(xin/Q2))
End if
ddFFS_equalzero = res
End Function ddFFS_equalzero

Complex(dp) Function dFFS_equalzero(xin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFSbar(x,y,z) = J(x,x) + 2x*I(x,x,0)
If (VerySmallM(Abs(xin),q2,q2,q2)) Then
 res = 0
Else
 res = -2._dp*xin*(-3._dp + ZLog(xin/Q2))*(-2._dp + ZLOG(xin/Q2))
End if
dFFS_equalzero = res
End Function dFFS_equalzero

Complex(dp) Function ddFFVbar_12(xin,yin,zin,Q2)
Implicit None
Complex(dp), Intent(in) :: xin,yin,zin
Real(dp), Intent(in) :: Q2
Complex(dp) :: res
! fFFVbar(x,y,z) = 6I(x,y,z)
res = 6*ddI_12(xin,yin,zin,Q2)
! If (res.ne.res) write(*,*) "NaN appearing in ddFFVbar_12"
ddFFVbar_12 = res
End Function ddFFVbar_12

Complex(dp) Function J_SMartinC(x,Q2)
Implicit None
Complex(dp), Intent(in) :: x
Real(dp), Intent(in) :: Q2
If (VerySmallM(Real(x,dp),Q2)) then
  J_SMartinC = ZeroC
Else
  J_SMartinC = x*(log(x/Q2)-1._dp)
End If
End Function J_SMartinC

Complex(dp) Function dJ2x_1(x,y,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: x,y
Complex(dp) :: res
If (VerySmallM(Real(x,dp),Max(Real(y,dp),Q2)).or.VerySmallM(Real(y,dp),Max(Real(x,dp),Q2))) then
  res = ZeroC
else If (SmallM(Real(x,dp),Max(Real(y,dp),Q2))) then
 If (SmallM(Real(y,dp),Q2)) Then
  res = y*Log(x/Q2)*(-1._dp + Log(y/q2))
 Else
  res = y*Log(x/Q2)*(-1._dp + Log(y/Q2))
 End if
Else
  res = log(x/Q2)*J_SMartinC(y,Q2)
End if
If (res.ne.res) write(*,*) "NaN appearing in dJ2x_1", Real(x,dp), Real(y,dp)
dJ2x_1 = res
End Function dJ2x_1

Complex(dp) Function ddJ2x_11(x,y,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: x,y
Complex(dp) :: res
If (VerySmallM(Real(x,dp),Max(Real(y,dp),Q2))) then
  res =  ZeroC
Else
  res = J_SMartinC(y,Q2)*1._dp/x
End If
If (res.ne.res) write(*,*) "NaN appearing in ddJ2x_11"
ddJ2x_11 = res
End Function ddJ2x_11

Complex(dp) Function ddJ2x_12(x,y,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: x,y
Complex(dp) :: res
If ((VerySmallM(Real(x,dp),Max(Real(y,dp),Q2))).or.(VerySmallM(Real(y),Max(Real(x),Q2)))) then
  res = ZeroC
Else
  res = log(x/Q2)*log(y/Q2)
End if

If (res.ne.res) write(*,*) "NaN appearing in ddJ2x_12"
ddJ2x_12 = res
End Function ddJ2x_12

Complex(dp) Function dJ(x,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: x
Complex(dp) :: res
If (VerySmallM(Real(x,dp),Q2)) then
  res = ZeroC
Else
  res = log(x/Q2)
End if
If (res.ne.res) write(*,*) "NaN appearing in dJ"
dJ = res
End Function dJ

Complex(dp) Function ddJ(x,Q2)
Implicit None
Real(dp), Intent(in) :: Q2
Complex(dp), Intent(in) :: x
Complex(dp) :: res
If (VerySmallM(Real(x,dp),Q2)) then
  res = ZeroC
Else
  res = 1._dp/x
End if

If (res.ne.res) write(*,*) "NaN appearing in ddJ"
ddJ = res
End Function ddJ

! balls topology functions SS, VS

Complex(dp) Function dSS_1(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fSS(x,y) = J(x,y)
res = dJ2x_1(x,y,Q2)
dSS_1 = res
If (res.ne.res) write(*,*) "NaN appearing in dSS_1"
End Function dSS_1

Complex(dp) Function ddSS_11(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fSS(x,y) = J(x,y)
res = ddJ2x_11(x,y,Q2)
ddSS_11 = res
! If (res.ne.res) write(*,*) "NaN appearing in ddSS_11"
End Function ddSS_11

Complex(dp) Function ddSS_12(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fSS(x,y) = J(x,y)
res = ddJ2x_12(x,y,Q2)
ddSS_12 = res
! If (res.ne.res) write(*,*) "NaN appearing in ddSS_12"
End Function ddSS_12

Complex(dp) Function dVS_1(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fVS(x,y) = 3J(x,y)
res = 3._dp*dJ2x_1(x,y,Q2)
dVS_1 = res
! If (res.ne.res) write(*,*) "NaN appearing in dVS_1"
End Function dVS_1

Complex(dp) Function ddVS_11(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fVS(x,y) = 3J(x,y)
res = 3._dp*ddJ2x_11(x,y,Q2)
ddVS_11 = res
! If (res.ne.res) write(*,*) "NaN appearing in ddVS_11"
End Function ddVS_11

Complex(dp) Function ddVS_12(xin,yin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,Q2
Complex(dp) :: res,x,y
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
! fVS(x,y) = 3J(x,y)
res = 3._dp*ddJ2x_12(x,y,Q2)
ddVS_12 = res
! If (res.ne.res) write(*,*) "NaN appearing in ddVS_12"
End Function ddVS_12

! sort two complex arguments by real part a<b
Subroutine SortTwoArgumentsC(a,b)
Implicit None
Complex(dp), Intent(inout) :: a,b
Complex(dp) :: x
If (Abs(b).le.Abs(a)) Then
  x = b
  b = a
  a = x
End If
End Subroutine SortTwoArgumentsC

!! DO NOT DELETE !!! FUNCTION BODY for copy paste
Complex(dp) Function newfunc(xin,yin,zin,Q2)
Implicit None
Real(dp), Intent(in) :: xin,yin,zin,Q2
Complex(dp) :: x,y,z ! complexify input values
Complex(dp) :: res
x = Cmplx(xin,0.,dp)
y = Cmplx(yin,0.,dp)
z = Cmplx(zin,0.,dp)

If (res.ne.res) write(*,*) "NaN appearing in newfunc"
newfunc = res
End Function newfunc

Complex(dp) Function dXi_1(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: R,Rx,Xi,dtemp
R=Rfunction(x,y,z)
Xi=XiFunction(x,y,z)
Rx=dR_1(x,y,z)
dtemp = -(ZLOG(y/z)/x)+(2._dp*(ZLOG((-R+x-y+z)/(4._dp*z))+ZLOG((R+x-y+z)/z)))&
&/(R+x-y-z)+(LOG(16._dp)-2._dp*ZLOG((-R-x+y+z)/z)-2._dp*ZLOG((R-x+&
&y+z)/z))/(R-x+y-z)
dXi_1 = Rx*(Xi/R) + R*dtemp
! doesn't work that well!

dXi_1 = ZSQRT(x**2+(y-z)**2-2*x*(y+z))*(-(ZLOG(y/z)/x)+(2*ZLOG((x-y+z-&
&ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-z)**2-&
&2*x*(y+z))+(2*(1+(-x+y+z)/ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
&*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(x-y+&
&z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))+(2*ZLOG((x-y+z+ZSQRT(x**2+&
&(y-z)**2-2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))&
&-(2*(-x+y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*ZLOG((-x+y+&
&z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(ZSQRT(x**2+(y-z)&
&**2-2*x*(y+z))*(-x+y-z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))))&
&+((x-y-z)*(Pi**2-3*ZLOG(x/z)*ZLOG(y/z)+6*ZLOG((x-y+z-ZSQRT(x**2+&
&(y-z)**2-2*x*(y+z)))/(2.*z))*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)&
&**2-2*x*(y+z)))/(2.*z))-6*PolyLog(2,(x-y+z-ZSQRT(x**2+(y-z)&
&**2-2*x*(y+z)))/(2.*z))-6*PolyLog(2,(-x+y+z-ZSQRT(x**2+(y-&
&z)**2-2*x*(y+z)))/(2.*z))))/(3.*ZSQRT(x**2+(y-z)**2-2*x*(y+z)))

End Function dXi_1

Complex(dp) Function ddXi_11(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: R,Rx,Rxx,Xi,dtempx,ddtempxx

If (.false.) then

  R=Rfunction(x,y,z)
  Xi=XiFunction(x,y,z)
  Rx=dR_1(x,y,z)
  Rxx=ddR_11(x,y,z)
  dtempx = -(ZLOG(y/z)/x)+(2._dp*(ZLOG((-R+x-y+z)/(4._dp*z))+ZLOG((R+x-y+z)/z)))&
  &/(R+x-y-z)+(dlog(16._dp)-2._dp*ZLOG((-R-x+y+z)/z)-2._dp*ZLOG((R-x+&
  &y+z)/z))/(R-x+y-z)
  ddtempxx = -4._dp/((R+x-y-z)*(R-x+y-z))+2._dp/((R+x-y-z)*(R+x-y+z))&
  &+2._dp/((R-x+y-z)*(R-x+y+z))+ZLOG(y/z)/x**2-(2*ZLOG((-R+x-&
  &y+z)/(2._dp*z)))/(R+x-y-z)**2+(DLog(4._dp)-2._dp*ZLOG((R+x-y+z)/z))&
  &/(R+x-y-z)**2-(2._dp*ZLOG((-R-x+y+z)/(2._dp*z)))/(R-x+y-z)**2+&
  &(DLOG(4._dp)-2._dp*ZLOG((R-x+y+z)/z))/(R-x+y-z)**2
  ddXi_11 = Rxx*Xi/R+2._dp*Rx*dtempx+R*ddtempxx

else

  ddXi_11 = ((2*x-2*(y+z))*(-(ZLOG(y/z)/x)+(2*ZLOG((x-y+z-ZSQRT(x**2+(y-&
  &z)**2-2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))+(2*(1+&
  &(-x+y+z)/ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*ZLOG((-x+y+z-ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))/(2.*z)))/(x-y+z-ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))+(2*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
  &/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))-(2*(-x+y+z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z)))/(2.*z)))/(ZSQRT(x**2+(y-z)**2-2*x*(y+z))*(-x+y-z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z))))))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z))*((-4*(-x+y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z))))/((x**2+(y-z)**2-2*x*(y+z))*(-x+y-z+ZSQRT(x**2+(y-&
  &z)**2-2*x*(y+z))))+ZLOG(y/z)/x**2-(2*(x-y-z)*ZLOG((x-y+z-&
  &ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(x**2+(y-z)**2-2*x*(y+&
  &z))**1.5+2*(-((1+(-x+y+z)/ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
  &**2/(x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))**2)-(4*y*z)/((x**2+&
  &(y-z)**2-2*x*(y+z))**1.5*(-x+y-z+ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z)))))*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))&
  &+(2*(x**2-2*x*y+y**2-2*x*z-2*y*z+z**2+x*ZSQRT(x**2+(y-z)&
  &**2-2*x*(y+z))-y*ZSQRT(x**2+(y-z)**2-2*x*(y+z))-z*ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z))-(x-y-z)*(x-y+z+ZSQRT(x**2+(y-z)&
  &**2-2*x*(y+z)))*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
  &/(2.*z))))/((x**2+(y-z)**2-2*x*(y+z))**1.5*(x-y+z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z))))-2*(-((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/((x**2+(y-z)**2-2*x*(y+z))*(-x+y-z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))))+(4*y*z*ZLOG((-x+y+z+ZSQRT(x**2+(y-&
  &z)**2-2*x*(y+z)))/(2.*z)))/((x**2+(y-z)**2-2*x*(y+z))**1.5*(-&
  &x+y-z+ZSQRT(x**2+(y-z)**2-2*x*(y+z))))+((-x+y+z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))**2*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z)))/((x**2+(y-z)**2-2*x*(y+z))*(x-y+z-ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))**2)))-(4*y*z*(Pi**2-3*ZLOG(x/z)*ZLOG(y/z)+&
  &6*ZLOG((x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))*ZLOG((-&
  &x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))-6*POLYLOG(2,&
  &(x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))-6*POLYLOG(2,&
  &(-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))))/(3.*(x**2+&
  &(y-z)**2-2*x*(y+z))**1.5)

end if

End Function ddXi_11

Complex(dp) Function ddXi_12(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: R,Rx,Ry,Rxy,Xi,dtempx,dtempy,ddtempxy

if (.false.) then
  R=Rfunction(x,y,z)
  Xi=XiFunction(x,y,z)
  Rx=dR_1(x,y,z)
  Ry=dR_1(y,x,z)
  Rxy=ddR_11(x,y,z)
  dtempx = -(ZLOG(y/z)/x)+(2*(ZLOG((-R+x-y+z)/(4.*z))+ZLOG((R+x-y+z)/z)))&
  &/(R+x-y-z)+(dlog(16._dp)-2*ZLOG((-R-x+y+z)/z)-2*ZLOG((R-x+&
  &y+z)/z))/(R-x+y-z)
  dtempy = DLOG(4._dp)/(R+x-y-z)-ZLOG(x/z)/y+(2._dp*ZLOG((-R+x-y+z)/(2._dp*z)))/(-&
  &R-x+y+z)-(2._dp*ZLOG((R+x-y+z)/z))/(R+x-y-z)+(2._dp*(ZLOG((-&
  &R-x+y+z)/(4._dp*z))+ZLOG((R-x+y+z)/z)))/(R-x+y-z)
  ddtempxy = -(1._dp/(x*y))+4._dp/((R+x-y-z)*(R-x+y-z))-2._dp/((R+x-y-z)*(R+&
  &x-y+z))-2._dp/((R-x+y-z)*(R-x+y+z))+(2._dp*ZLOG((-R+x-y+&
  &z)/(2._dp*z)))/(R+x-y-z)**2+(2._dp*ZLOG((R+x-y+z)/(2._dp*z)))/(R+x-&
  &y-z)**2+(2._dp*ZLOG((-R-x+y+z)/(2._dp*z)))/(R-x+y-z)**2+(2._dp*ZLOG((R-&
  &x+y+z)/(2._dp*z)))/(R-x+y-z)**2
  ddXi_12 = Rxy*Xi/R+Rx*dtempy+Ry*dtempx+R*ddtempxy
else

  ddXi_12 = (-2*z*(-x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*(-x**3+x**2*y+&
  &x*y**2-y**3+3*x**2*z+2*x*y*z+3*y**2*z-3*x*z**2-3*y*z**2+z**3+&
  &2*x*y*(x-y+z)*ZLOG((x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
  &/(2.*z))+2*x*y*(-x+y+z)*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))+2*x**2*y*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))-2*x*y**2*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))+2*x*y*z*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))-2*x**2*y*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))+2*x*y**2*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))+2*x*y*z*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z))))/(x*y*(x**2+(y-z)**2-2*x*(y+z))*(x-y+&
  &z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*(x-y-z+ZSQRT(x**2+(y-&
  &z)**2-2*x*(y+z))))+((2*x-2*(y+z))*(-(ZLOG(x/z)/y)+(2*(1+(x-&
  &y+z)/ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*ZLOG((x-y+z-ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))/(2.*z)))/(-x+y+z-ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))+(2*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))&
  &/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))-(2*(x-y+z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))*ZLOG((x-y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z)))/(2.*z)))/(ZSQRT(x**2+(y-z)**2-2*x*(y+z))*(x-y-z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z))))+(2*ZLOG((-x+y+z+ZSQRT(x**2+(y-z)**2-&
  &2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))))/(2.*ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))+((2*y-2*(x+z))*(-(ZLOG(y/z)/x)+(2*ZLOG((x-&
  &y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-&
  &z)**2-2*x*(y+z))+(2*(1+(-x+y+z)/ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z)))*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(x-&
  &y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))+(2*ZLOG((x-y+z+ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))/(2.*z)))/ZSQRT(x**2+(y-z)**2-2*x*(y+z))&
  &-(2*(-x+y+z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))*ZLOG((-x+y+&
  &z+ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(ZSQRT(x**2+(y-z)&
  &**2-2*x*(y+z))*(-x+y-z+ZSQRT(x**2+(y-z)**2-2*x*(y+z))))))&
  &/(2.*ZSQRT(x**2+(y-z)**2-2*x*(y+z)))+((x-y-z)*(x-y+z)*(Pi**2-&
  &3*ZLOG(x/z)*ZLOG(y/z)+6*ZLOG((x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+&
  &z)))/(2.*z))*ZLOG((-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))&
  &-6*PolyLog(2,(x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))&
  &-6*PolyLog(2,(-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))))&
  &/(3.*(x**2+(y-z)**2-2*x*(y+z))**1.5)+(-Pi**2+3*ZLOG(x/z)*ZLOG(y/z)&
  &-6*ZLOG((x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))*ZLOG((-&
  &x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))+6*PolyLog(2,&
  &(x-y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z))+6*PolyLog(2,&
  &(-x+y+z-ZSQRT(x**2+(y-z)**2-2*x*(y+z)))/(2.*z)))/(3.*ZSQRT(x**2+&
  &(y-z)**2-2*x*(y+z)))
end if
End Function ddXi_12

Complex(dp) Function dR_1(x,yin,zin)
Implicit None
Complex(dp), Intent(in) :: x,yin,zin
Complex(dp) :: R,y,z
y = yin
z = zin
Call SortTwoArgumentsC(y,z)
R=Rfunction(x,y,z)
If (VerySmallM(x,y,z,0._dp)) then
  If (VerySmallM(y,x,z,0._dp)) then
    ! R_x(0,0,z)
    dR_1 = -1._dp
  Else
    ! R_x(0,y,z)
    dR_1 = -(y+z)/ZSQRT((y-z)**2.)
  end if
else
  If (VerySmallM(y,x,z,0._dp)) then
    ! R_x(x,0,z)
    dR_1 = (x-z)/ZSQRT((x-z)**2.)
  else
    ! R_x(x,y,z)
    dR_1 = (x-y-z)/R
  end if
end if
End Function dR_1

Complex(dp) Function ddR_11(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: R
R=Rfunction(x,y,z)
ddR_11 = -4._dp*y*z/(R**3)
End Function ddR_11

Complex(dp) Function ddR_12(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: R
R=Rfunction(x,y,z)
ddR_12 = 2._dp*(x+y-z)*z/(R**3)
End Function ddR_12

End Module DerivativesEffPotFunctions


pure function zhangI(m, k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: hyp2f1
  use m_hyp2f1_negint, only: hyp2f1_negint
  implicit none
  integer, intent(in) :: m
  real(dp), intent(in) :: k, rc
  real(dp) :: zhangI
  real(dp), parameter :: pi = 4._dp * atan(1._dp)
  real(dp) :: h2f1
  if (mod(m, 2) == 0) then
     h2f1 = hyp2f1(-(m - 1) / 2._dp, -(m - 3) / 2._dp, 1._dp, k**2)
  else
     h2f1 = hyp2f1_negint(-(m - 1) / 2, -(m - 3) / 2, 1, k**2)
  end if
  zhangI = 2 / ((m - 1) * rc**(m - 1) * (1 - k**2)**(m - 1)) * pi * h2f1
end function zhangI

!> Derivative of zhangI with respect to k.
pure function d_zhangI(m, k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: hyp2f1
  use m_hyp2f1_negint, only: hyp2f1_negint
  implicit none
  integer, intent(in) :: m
  real(dp), intent(in) :: k, rc
  real(dp) :: d_zhangI
  real(dp), parameter :: pi = 4 * atan(1._dp)
  if (mod(m, 2) /= 0 .and. m > 3) then
     d_zhangI = -k * (1 - k**2)**(-m) * pi * rc**(1 - m) * &
          (-4 * hyp2f1_negint((1 - m) / 2, (3 - m) / 2, 1, k**2) + &
          (-1 + k**2) * (-3 + m) * &
          hyp2f1_negint((3 - m) / 2, (5 - m) / 2, 2, k**2))
  else
     d_zhangI = -k * (1 - k**2)**(-m) * pi * rc**(1 - m) * &
          (-4 * hyp2f1((1 - m) / 2._dp, (3 - m) / 2._dp, 1._dp, k**2) + &
          (-1 + k**2) * (-3 + m) * &
          hyp2f1((3 - m) / 2._dp, (5 - m) / 2._dp, 2._dp, k**2))
  end if
end function d_zhangI

pure function repwall2(k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: zhangI
  implicit none
  real(dp), intent(in) :: k, rc
  real(dp) :: repwall2
  real(dp), parameter :: pi = 4._dp * atan(1._dp)
  repwall2 = 63. * pi / 64 * zhangI(10, k, rc)
end function repwall2

pure function attwall2(k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: zhangI
  implicit none
  real(dp), intent(in) :: k, rc
  real(dp) :: attwall2
  real(dp), parameter :: pi = 4._dp * atan(1._dp)
  attwall2 = 3. * pi  / 2 * zhangI(4, k, rc)
end function attwall2

pure function d_repwall(k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: d_zhangI
  implicit none
  real(dp), intent(in) :: k, rc
  real(dp) :: d_repwall
  real(dp), parameter :: pi = 4._dp * atan(1._dp)
  d_repwall = 63. * pi / 64. * d_zhangI(10, k, rc)
end function d_repwall

pure function d_attwall(k, rc)
  use num_kind, only: dp
  use cylinder_integrals, only: d_zhangI
  implicit none
  real(dp), intent(in) :: k, rc
  real(dp) :: d_attwall
  real(dp), parameter :: pi = 4. * atan(1._dp)
  d_attwall = 3. * pi / 2. * d_zhangI(4, k, rc)
end function d_attwall


      subroutine cblas()
      call caxpy(n,ca,cx,incx,cy,incy)
      call  ccopy(n,cx,incx,cy,incy)
      c =  cdotc(n,cx,incx,cy,incy)
      c =  cdotu(n,cx,incx,cy,incy)
      r = cmach(job)
      call crotg(ca,cb,c,s)
      call  cscal(n,ca,cx,incx)
      call  csrot (n,cx,incx,cy,incy,c,s)
      call  csscal(n,sa,cx,incx)
      call  cswap (n,cx,incx,cy,incy)
      i = icamax(n,cx,incx)
      r = scasum(n,cx,incx)
      r = scnrm2( n, cx, incx)
      call srotg(sa,sb,c,s)
      stop
      end


      SUBROUTINE quadct(x,y,xx,yy,nn,fa,fb,fc,fd)
      INTEGER nn
      REAL fa,fb,fc,fd,x,y,xx(nn),yy(nn)
      INTEGER k,na,nb,nc,nd
      REAL ff
      na=0
      nb=0
      nc=0
      nd=0
      do 11 k=1,nn
        if(yy(k).gt.y)then
          if(xx(k).gt.x)then
            na=na+1
          else
            nb=nb+1
          endif
        else
          if(xx(k).gt.x)then
            nd=nd+1
          else
            nc=nc+1
          endif
        endif
11    continue
      ff=1.0/nn
      fa=ff*na
      fb=ff*nb
      fc=ff*nc
      fd=ff*nd
      return
      END

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


subroutine cubspl ( tau, c, n, ibcbeg, ibcend )

!*****************************************************************************80
!
!! CUBSPL defines an interpolatory cubic spline.
!
!  Discussion:
!
!    A tridiagonal linear system for the unknown slopes S(I) of
!    F at TAU(I), I=1,..., N, is generated and then solved by Gauss
!    elimination, with S(I) ending up in C(2,I), for all I.
!
!  Modified:
!
!    14 February 2007
!
!  Author:
!
!    Carl de Boor
!
!  Reference:
!
!    Carl de Boor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663,
!    LC: QA1.A647.v27.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) TAU(N), the abscissas or X values of
!    the data points.  The entries of TAU are assumed to be
!    strictly increasing.
!
!    Input, integer ( kind = 4 ) N, the number of data points.  N is
!    assumed to be at least 2.
!
!    Input/output, real ( kind = 8 ) C(4,N).
!    On input, if IBCBEG or IBCBEG is 1 or 2, then C(2,1)
!    or C(2,N) should have been set to the desired derivative
!    values, as described further under IBCBEG and IBCEND.
!    On output, C contains the polynomial coefficients of
!    the cubic interpolating spline with interior knots
!    TAU(2) through TAU(N-1).
!    In the interval interval (TAU(I), TAU(I+1)), the spline
!    F is given by
!      F(X) =
!        C(1,I) +
!        C(2,I) * H +
!        C(3,I) * H^2 / 2 +
!        C(4,I) * H^3 / 6.
!    where H=X-TAU(I).  The routine PPVALU may be used to
!    evaluate F or its derivatives from TAU, C, L=N-1,
!    and K=4.
!
!    Input, integer ( kind = 4 ) IBCBEG, IBCEND, boundary condition indicators.
!    IBCBEG = 0 means no boundary condition at TAU(1) is given.
!    In this case, the "not-a-knot condition" is used.  That
!    is, the jump in the third derivative across TAU(2) is
!    forced to zero.  Thus the first and the second cubic
!    polynomial pieces are made to coincide.
!    IBCBEG = 1 means the slope at TAU(1) is to equal the
!    input value C(2,1).
!    IBCBEG = 2 means the second derivative at TAU(1) is
!    to equal C(2,1).
!    IBCEND = 0, 1, or 2 has analogous meaning concerning the
!    boundary condition at TAU(N), with the additional
!    information taken from C(2,N).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) c(4,n)
  real ( kind = 8 ) divdf1
  real ( kind = 8 ) divdf3
  real ( kind = 8 ) dtau
  real ( kind = 8 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ibcbeg
  integer ( kind = 4 ) ibcend
  real ( kind = 8 ) tau(n)
!
!  C(3,*) and C(4,*) are used initially for temporary storage.
!
!  Store first differences of the TAU sequence in C(3,*).
!
!  Store first divided difference of data in C(4,*).
!
  do i = 2, n
    c(3,i) = tau(i) - tau(i-1)
  end do

  do i = 2, n
    c(4,i) = ( c(1,i) - c(1,i-1) ) / ( tau(i) - tau(i-1) )
  end do
!
!  Construct the first equation from the boundary condition
!  at the left endpoint, of the form:
!
!    C(4,1) * S(1) + C(3,1) * S(2) = C(2,1)
!
!  IBCBEG = 0: Not-a-knot
!
  if ( ibcbeg == 0 ) then

    if ( n <= 2 ) then
      c(4,1) = 1.0D+00
      c(3,1) = 1.0D+00
      c(2,1) = 2.0D+00 * c(4,2)
      go to 120
    end if

    c(4,1) = c(3,3)
    c(3,1) = c(3,2) + c(3,3)
    c(2,1) = ( ( c(3,2) + 2.0D+00 * c(3,1) ) * c(4,2) * c(3,3) &
      + c(3,2)**2 * c(4,3) ) / c(3,1)
!
!  IBCBEG = 1: derivative specified.
!
  else if ( ibcbeg == 1 ) then

    c(4,1) = 1.0D+00
    c(3,1) = 0.0D+00

    if ( n == 2 ) then
      go to 120
    end if
!
!  Second derivative prescribed at left end.
!
  else

    c(4,1) = 2.0D+00
    c(3,1) = 1.0D+00
    c(2,1) = 3.0D+00 * c(4,2) - c(3,2) / 2.0D+00 * c(2,1)

    if ( n == 2 ) then
      go to 120
    end if

  end if
!
!  If there are interior knots, generate the corresponding
!  equations and carry out the forward pass of Gauss elimination,
!  after which the I-th equation reads:
!
!    C(4,I) * S(I) + C(3,I) * S(I+1) = C(2,I).
!
  do i = 2, n-1
    g = -c(3,i+1) / c(4,i-1)
    c(2,i) = g * c(2,i-1) + 3.0D+00 * ( c(3,i) * c(4,i+1) + c(3,i+1) * c(4,i) )
    c(4,i) = g * c(3,i-1) + 2.0D+00 * ( c(3,i) + c(3,i+1))
  end do
!
!  Construct the last equation from the second boundary condition, of
!  the form
!
!    -G * C(4,N-1) * S(N-1) + C(4,N) * S(N) = C(2,N)
!
!  If slope is prescribed at right end, one can go directly to
!  back-substitution, since the C array happens to be set up just
!  right for it at this point.
!
  if ( ibcend == 1 ) then
    go to 160
  end if

  if ( 1 < ibcend ) then
    go to 110
  end if

90    continue
!
!  Not-a-knot and 3 <= N, and either 3 < N or also not-a-knot
!  at left end point.
!
  if ( n /= 3 .or. ibcbeg /= 0 ) then
    g = c(3,n-1) + c(3,n)
    c(2,n) = ( ( c(3,n) + 2.0D+00 * g ) * c(4,n) * c(3,n-1) + c(3,n)**2 &
      * ( c(1,n-1) - c(1,n-2) ) / c(3,n-1) ) / g
    g = - g / c(4,n-1)
    c(4,n) = c(3,n-1)
    c(4,n) = c(4,n) + g * c(3,n-1)
    c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
    go to 160
  end if
!
!  N = 3 and not-a-knot also at left.
!
100   continue

  c(2,n) = 2.0D+00 * c(4,n)
  c(4,n) = 1.0D+00
  g = -1.0D+00 / c(4,n-1)
  c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
  c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
  go to 160
!
!  IBCEND = 2: Second derivative prescribed at right endpoint.
!
110   continue

  c(2,n) = 3.0D+00 * c(4,n) + c(3,n) / 2.0D+00 * c(2,n)
  c(4,n) = 2.0D+00
  g = -1.0D+00 / c(4,n-1)
  c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
  c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)
  go to 160
!
!  N = 2.
!
120   continue

  if ( ibcend == 2  ) then

    c(2,n) = 3.0D+00 * c(4,n) + c(3,n) / 2.0D+00 * c(2,n)
    c(4,n) = 2.0D+00
    g = -1.0D+00 / c(4,n-1)
    c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
    c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)

  else if ( ibcend == 0 .and. ibcbeg /= 0 ) then

    c(2,n) = 2.0D+00 * c(4,n)
    c(4,n) = 1.0D+00
    g = -1.0D+00 / c(4,n-1)
    c(4,n) = c(4,n) - c(3,n-1) / c(4,n-1)
    c(2,n) = ( g * c(2,n-1) + c(2,n) ) / c(4,n)

  else if ( ibcend == 0 .and. ibcbeg == 0 ) then

    c(2,n) = c(4,n)

  end if
!
!  Back solve the upper triangular system
!
!    C(4,I) * S(I) + C(3,I) * S(I+1) = B(I)
!
!  for the slopes C(2,I), given that S(N) is already known.
!
160   continue

  do i = n-1, 1, -1
    c(2,i) = ( c(2,i) - c(3,i) * c(2,i+1) ) / c(4,i)
  end do
!
!  Generate cubic coefficients in each interval, that is, the
!  derivatives at its left endpoint, from value and slope at its
!  endpoints.
!
  do i = 2, n
    dtau = c(3,i)
    divdf1 = ( c(1,i) - c(1,i-1) ) / dtau
    divdf3 = c(2,i-1) + c(2,i) - 2.0D+00 * divdf1
    c(3,i-1) = 2.0D+00 * ( divdf1 - c(2,i-1) - divdf3 ) / dtau
    c(4,i-1) = 6.0D+00 * divdf3 / dtau**2
  end do

  return
end


      FUNCTION gasdev(idum)
      INTEGER idum
      REAL gasdev
CU    USES ran1
      INTEGER iset
      REAL fac,gset,rsq,v1,v2,ran1
      SAVE iset,gset
      DATA iset/0/
      if (iset.eq.0) then
1       v1=2.*ran1(idum)-1.
        v2=2.*ran1(idum)-1.
        rsq=v1**2+v2**2
        if(rsq.ge.1..or.rsq.eq.0.)goto 1
        fac=sqrt(-2.*log(rsq)/rsq)
        gset=v1*fac
        gasdev=v2*fac
        iset=1
      else
        gasdev=gset
        iset=0
      endif
      return
      END

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


MODULE nrtype
  INTEGER, PARAMETER :: DP = KIND(1.0D0)
  REAL(DP), PARAMETER :: PI=3.141592653589793238462643383279502884197_dp
  REAL(DP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_dp
  REAL(DP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_dp
END MODULE nrtype

Module fft_coeff
  IMPLICIT NONE
  COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:) :: coef_d1, coef_d2, coef_d3, coef_d4
  INTEGER(KIND=4) :: fft_coeff_flag =0, fft_plan_flag=0, nend

  INTEGER(KIND=8) :: p_fw0, p_bw1, p_bw2, p_bw3, p_bw4
  REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: hh, d1h, d2h, d3h, d4h
  COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:) :: h_fft, dummy_c

  INCLUDE 'fftw3.f90'

  CONTAINS

    SUBROUTINE calculate_modes_r2c(nn, ll)
      USE nrtype
      IMPLICIT NONE

      INTEGER(KIND=4), INTENT(IN) :: nn
      REAL(KIND=8), INTENT(IN) :: ll
      INTEGER(KIND=4) :: k, kend

      fft_coeff_flag = 1
!
! nend: total number of Fourier coefficients
!
      IF(MOD(nn,2).EQ.0)THEN
         kend = nn/2
         nend = nn/2+1
      ELSE
         kend = (nn+1)/2
         nend = (nn+1)/2
      END IF

      ALLOCATE(coef_d1(1:nend))
      ALLOCATE(coef_d2(1:nend))
      ALLOCATE(coef_d3(1:nend))
      ALLOCATE(coef_d4(1:nend))
!
!  Setup fourier coefficients of derivatives
!
      coef_d1(1)=(0.0d0, 0.0d0)
      coef_d2(1)=(0.0d0, 0.0d0)
      coef_d3(1)=(0.0d0, 0.0d0)
      coef_d4(1)=(0.0d0, 0.0d0)
      DO k = 2, kend
         coef_d1(k) = DCMPLX(0.0d0, TWOPI*DBLE(k-1)/ll)
         coef_d2(k) = DCMPLX(-(TWOPI*DBLE(k-1)/ll)**2, 0.0d0)
         coef_d3(k) = DCMPLX(0.0d0, -(TWOPI*DBLE(k-1)/ll)**3)
         coef_d4(k) = DCMPLX((TWOPI*DBLE(k-1)/ll)**4, 0.0d0)
      END DO
!
!  Coefficients for the Nyquist mode
!
      IF(MOD(nn,2).EQ.0)THEN
         coef_d1(nend) = (0.0d0, 0.0d0)
         coef_d2(nend) = DCMPLX(-(TWOPI*DBLE(nn/2)/ll)**2, 0.0d0)
         coef_d3(nend) = (0.0d0, 0.0d0)
         coef_d4(nend) = DCMPLX((TWOPI*DBLE(nn/2)/ll)**4, 0.0d0)
      END IF

      RETURN
    END SUBROUTINE calculate_modes_r2c

    SUBROUTINE create_fftw_plan(nn)
      IMPLICIT NONE
      INTEGER(KIND=4), INTENT(IN) :: nn
      INTEGER :: kend

      fft_plan_flag = 1

      IF(MOD(nn,2).EQ.0)THEN
         kend = nn/2+1
      ELSE
         kend = (nn+1)/2
      END IF

      ALLOCATE(hh(1:nn))
      ALLOCATE(d1h(1:nn))
      ALLOCATE(d2h(1:nn))
      ALLOCATE(d3h(1:nn))
      ALLOCATE(d4h(1:nn))

      ALLOCATE(h_fft(1:kend))
      ALLOCATE(dummy_c(1:kend))

      CALL dfftw_plan_dft_r2c_1d(p_fw0, nn, hh,      h_fft, FFTW_MEASURE+FFTW_PRESERVE_INPUT)
      CALL dfftw_plan_dft_c2r_1d(p_bw1, nn, dummy_c, d1h,   FFTW_MEASURE)
      CALL dfftw_plan_dft_c2r_1d(p_bw2, nn, dummy_c, d2h,   FFTW_MEASURE)
      CALL dfftw_plan_dft_c2r_1d(p_bw3, nn, dummy_c, d3h,   FFTW_MEASURE)
      CALL dfftw_plan_dft_c2r_1d(p_bw4, nn, dummy_c, d4h,   FFTW_MEASURE)

      RETURN
    END SUBROUTINE create_fftw_plan

END Module fft_coeff

!----------------------------------------------------------------------
!----------------------------------------------------------------------
!  ks : Kuramoto-Sivashinski equation
!
!   h_t - c*h_x + h*h_x + h_xx + nu*h_xxxx=0, x\in[-pi,pi]
!   with periodic boundary conditions
!
!  Only derivatives are calculated using FFTW in the Fourier space
!
!----------------------------------------------------------------------
SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
  USE nrtype
  USE fft_coeff
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  REAL(DP), INTENT(IN) :: U(NDIM), PAR(*)
  REAL(DP), INTENT(OUT) :: F(NDIM), DFDU(NDIM,NDIM), DFDP(NDIM,*)

  INTEGER :: nn, kk
  REAL(DP) :: nu, cc, tmp, tmp2, dx

  nn = NDIM+1

! Initialisation: calculate fourier modes
  IF(fft_coeff_flag.EQ.0) CALL calculate_modes_r2c(nn, TWOPI)

! Initilize FFTW and create plans
  IF(fft_plan_flag.EQ.0) CALL create_fftw_plan(nn)

  DO kk = 2, nn
     hh(kk) = U(kk-1)
  END DO
  hh(1) = -SUM(hh(2:nn))

! Compute h_fft from hh:
  CALL dfftw_execute_dft_r2c(p_fw0, hh, h_fft)

! Compute d1h (h_x) ~ d4h (h_xxxx):
  DO kk=1, nend
     dummy_c(kk) = coef_d1(kk)*h_fft(kk)/DBLE(nn)
  END DO
  CALL dfftw_execute_dft_c2r(p_bw1, dummy_c, d1h)
  DO kk=1, nend
     dummy_c(kk) = coef_d2(kk)*h_fft(kk)/DBLE(nn)
  END DO
  CALL dfftw_execute_dft_c2r(p_bw2, dummy_c, d2h)
  DO kk=1, nend
     dummy_c(kk) = coef_d3(kk)*h_fft(kk)/DBLE(nn)
  END DO
  CALL dfftw_execute_dft_c2r(p_bw3, dummy_c, d3h)
  DO kk=1, nend
     dummy_c(kk) = coef_d4(kk)*h_fft(kk)/DBLE(nn)
  END DO
  CALL dfftw_execute_dft_c2r(p_bw4, dummy_c, d4h)

  nu   = PAR(1)

  tmp = 0.0d0
  tmp2 = 0.0d0
  dx = TWOPI/DBLE(nn)
  DO kk=1, nn
     tmp = tmp + hh(kk)*DSIN(1.0d0*dx*DBLE(kk-1))
     tmp2 = tmp2 + (hh(kk)**2)*DSIN(1.0d0*dx*DBLE(kk-1))
  END DO
  IF(DABS(tmp).LT.1.0d-4)THEN
     cc = 0.0d0
  ELSE
     cc = 0.5d0*tmp2/tmp
  END IF

  DO kk=2, nn
     F(kk-1) = cc*d1h(kk) - hh(kk)*d1h(kk) - d2h(kk) - nu*d4h(kk)
  END DO

  RETURN
END SUBROUTINE FUNC

SUBROUTINE STPNT(NDIM,U,PAR,T)
  USE nrtype
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  REAL(DP), INTENT(INOUT) :: U(NDIM),PAR(*)
  REAL(DP), INTENT(IN) :: T
  INTEGER :: nn, kk
  REAL(DP) :: nu, dx

  nn = NDIM+1

! Initialise the equation parameters:
  nu  = 1.0d0/(2.0d0**2)

  PAR(1) = nu

!  par(11) = 1.0; ! Internal period, set to one and do not touch

! Initial condition
  dx = TWOPI/DBLE(nn)
  DO kk = 1, NDIM
     U(kk) = 1.0d-3*DSIN(dx*DBLE(kk)*2.0d0)
  END DO

  RETURN
END SUBROUTINE STPNT

SUBROUTINE BCND
  RETURN
END SUBROUTINE BCND

SUBROUTINE ICND
  RETURN
END SUBROUTINE ICND

SUBROUTINE PVLS(NDIM,U,PAR)
  USE nrtype
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  REAL(DP), INTENT(IN) :: U(NDIM)
  REAL(DP), INTENT(INOUT) :: PAR(*)

  REAL(DP), EXTERNAL :: GETP,GETU2
  REAL(DP) :: tmp, tmp2, dx
  INTEGER :: kk
!----------------------------------------------------------------------
! NOTE :
! parameters set in this subroutine should be considered as ``solution
! measures'' and be used for output purposes only.
!
! they should never be used as `true'' continuation parameters.
!
! they may, however, be added as ``over-specified parameters'' in the
! parameter list associated with the auto-constant nicp, in order to
! print their values on the screen and in the ``p.xxx file.
!
! they may also appear in the list associated with auto-constant nuzr.
!
!----------------------------------------------------------------------
! for algebraic problems the argument u is, as usual, the state vector.
! for differential equations the argument u represents the approximate
! solution on the entire interval [0,1]. in this case its values must
! be accessed indirectly by calls to getp, as illustrated below.
!----------------------------------------------------------------------
!
! set par(2) equal to the l2-norm of u(1)
!       par(2)=getp('nrm',1,u)
!
! set par(3) equal to the minimum of u(2)
!       par(3)=getp('min',2,u)
!
! set par(4) equal to the value of u(2) at the left boundary.
!       par(4)=getp('bv0',2,u)
!
! set par(5) equal to the pseudo-arclength step size used.
!       par(5)=getp('stp',1,u)
!
!----------------------------------------------------------------------
! the first argument of getp may be one of the following:
!        'nrm' (l2-norm),     'max' (maximum),
!        'int' (integral),    'bv0 (left boundary value),
!        'min' (minimum),     'bv1' (right boundary value).
!
! also available are
!   'stp' (pseudo-arclength step size used).
!   'fld' (`fold function', which vanishes at folds).
!   'bif' (`bifurcation function', which vanishes at singular points).
!   'hbf' (`hopf function'; which vanishes at hopf points).
!   'spb' ( function which vanishes at secondary periodic bifurcations).
!   'eig' ( obtains eigenvalues and floquet multipliers:
!            index 1, 3, 5,... obtain the real parts of ev's
!              and 2, 4, 6,... the imaginary parts
!            eigenvalues are ordered by real part.
!            floquet multipliers are ordered by distance from |z|=1)
!   'nbc' ( gets the active nbc).
!   'nint' ( gets the active nint).
!   'ntst' ( gets the active ntst).
!   'ncol' ( gets the active ncol).
!   'ndim' ( get the dimension of the extended system).
!   'mxt' ( gets t value for maximum of component).
!   'mnt' ( gets t value for minumum of component).
!   'win' ( gets weight for integral; 0<=i<=ncol).
!   'dtm' ( gets value for delta t array 1<=i<=ntst).
!----------------------------------------------------------------------

  tmp = 0.0d0
  tmp2 = 0.0d0
  dx = TWOPI/DBLE(NDIM+1)
  DO kk=1, NDIM
     tmp = tmp + getp('INT', kk, u)*DSIN(1.0d0*dx*DBLE(kk))
     tmp2 = tmp2 + (getp('INT', kk, u)**2)*DSIN(1.0d0*dx*DBLE(kk))
  END DO
  IF(DABS(tmp).LT.1.0d-4)THEN
     PAR(6) = 0.0d0
  ELSE
     PAR(6) = 0.5d0*tmp2/tmp
  END IF

  tmp = 0.0d0
  tmp2 = 0.0d0
  DO kk=1, NDIM
     tmp = tmp + (getp('INT', kk, U))**2
     tmp2 = tmp2 + getp('INT', kk, U)
  END DO
  tmp = tmp + tmp2**2
  PAR(7) = DSQRT(tmp/DBLE(NDIM+1))

  RETURN
END SUBROUTINE PVLS

SUBROUTINE FOPT
  RETURN
END SUBROUTINE FOPT