!> @file evd_covariance.f90
!! Defines a general module for covariance matrices.
!<

!> @brief General module for covariance matrix
!!
!! @author Innocent Souopgui
!!
!! \details This module implements a set of subroutines for the covariance
!!   matrix for one and two dimensional problems
!!  Using the positive (semi) definiteness of the covariance matrices,
!!  the covariance matrix B is diagonalizable and its singular value
!!  decomposition is also its diagonalization in a basis of eigenvectors.
!! We consider the case where B is approximated using only the leading
!! eigenvectors, the full case being similar.
!! The covariance matrix is supposed to be given under a factorized forms
!!   \f[ B \approx UDU^T \f] where the colums of U are the leading eigenvectors
!!   of B and D is the diagonal matrix of the leading eigenvalues of B.
!! For the 2D, we consider the covariance function that factorises as a
!! product of covariance functions in each spatial dimension; so that the
!! covariance matrix B is the kronecker product of the covariance  matrices
!! in the single dimensions \f[ B = Kron(Bx,By) \f]. Bx and By are given under
!! their factorized forms \f[ B = Kron(Ux,Uy)*Kron(Dx,Dy)*Kron(Ux,Uy)^T \f],
!! where Dx is a diagonal matrix with leading eigenvalues of Bx on the diagonal
!! and Dy is a diagonal matrix with eigenvalues of By on the diagonal
!! Bx = Ux*Dx*Ux^T,  By = Uy*Dy*Uy^T.
!!The 2D covariance matrix applies to a vector that correspond to a discretization
!!  of a 2d function (function of two variables) on the same grid as the control
!!  variable. The chronecker product factorization depends on the ordering of
!!  the dimensions in the discretization as well as the vectorization of the 2D
!!  discretized function.
!!Suppose that the covariance function factorizes such that the covariances on
!!  the grid are combinations of the covariances in each direction,
!!  cov(p1, p2) = cov_x(x1,x2)cov_y(y1,y2) where p1 is the point of coordinates
!!  (x1,y1) and p2 (x2,y2). In this case B*f = Kron(B_x,B_y)*f where B_x and B_y
!!  are respectively the covariances in the direction x, resp. y.
!! According to the ordering of the discretization points and the vectorization
!!  order, that formula can change:
!! Let F be the matrix of a discretized function, and f its vectorized
!! representation.
!! 1) if the first dimension of F corresponds to the x direction (x-leading) then:
!!   - g=B*f = Kron(B_x,B_y)*f, if f is a row major vectorization
!!     (C-prefered ordering);
!!   - g=B*f = Kron(B_y,B_x)*f, if f is a column major vectorization
!!       (Fortran-prefered ordering).
!! 2) if the first dimension of F corresponds to the y direction (y-leading) then:
!!   - g=B*f = Kron(B_y,B_x)*f with a row major vectorization
!!      (C-prefered ordering) of F
!!   - g=B*f = Kron(B_x,B_y)*f, with a column major vectorization
!!      (Fortran-prefered ordering) of F.
!! All the 2D routines in this module are based on the formula
!! g=B*f = Kron(B_x,B_y)*f. It is assumed either :
!! - x-leading and row major vectorization or
!! - y-leading and column major vectorization
!!
!<
MODULE evd_covariance
  USE general_constant
  USE general_tools, only: readInfo, readMatrix, writeMatrix, fileExist
  USE debug_tools
  use kronecker
  use exponential_cov
  use evd_tools
IMPLICIT NONE

  private
  public evd_cov_matrix&
    , load_evd_covariance, save_evd_covariance&
    , apply_evd_cov, apply_evd_cov_inv&
    , apply_evd_square_cov, apply_evd_square_cov_inv&
    , apply_evd_square_covb&
    , get_evd_cov_nsv, make_evd_cov, get_evd_cov_size&
    , get_evd_cov_nRow
  !, cov_mv, cov_inv_mv, cov_square_mv, cov_square_mvb, cov_square_inv_mv&

  !> \brief default number of factors in the Kronecker factorization
  !!  of the covariance matrix, used for non initialized covariance matrix
  !<
  INTEGER, PARAMETER :: default_nFact=-1

    !> Derived type for singular values decomposed covariance matrices
    !! It is assumed that the covariance matrix is provided as its Singular
    !! Value Decomposition: B = UDUt. Furthermore, it can be (Kronecker)
    !! factorized along the physical dimensions of the problem:
    !! B = Bx kron By kron Bz
    type evd_cov_matrix

        !> \brief number of terms in the Kronecker factorization of
        !!  the covariance matrix.
        !!Conceptually, it corresponds to the number of physical dimensions
        !! of the problem if the covariance is factorized.
        !!Logically, it can be any Kronecker factorization.
        !<
        INTEGER, private :: im_nFac = default_nFact

        !> \brief matrix(ces) of singular vector of the covariance matrix
        !! \details If the covariance matrix B is not factorized, only Ux is initialized
        !! IF B is factorized as B = Bx kron By (two terms), Ux and Uy are provided
        !! A maximum of 3 terms in the factorization is supported.
        !<
        REAL(cp), private, ALLOCATABLE, DIMENSION(:,:):: Ux, Uy, Uz

        !> vector(s) of eigenvalues of B
        REAL(cp), private, ALLOCATABLE, DIMENSION(:) :: Dx, Dy, Dz

    end type evd_cov_matrix

!private procedures interface
  !> Covariance matrix vector product
  interface cov_mv
    module procedure cov_mv_default
    module procedure cov_mv_2fac
    module procedure cov_mv_3fac
  end interface cov_mv

  !> Inverse covariance matrix vector product
  interface cov_inv_mv
    module procedure cov_inv_mv_default
    module procedure cov_inv_mv_2fac
    module procedure cov_inv_mv_3fac
  end interface cov_inv_mv

  !> square root covariance matrix vector product
  !! Those subroutines actually apply the operator L derived from
  !! the eigenvalue decomposition of the covariance matrix.
  !! let B = UDU^t be the eigenvalue decomposition
  !! Those subroutines apply UD^(1/2)
  !! To apply the square root that should be UD^(1/2)U^T
  !! Those subroutines are used to generate multivariate random variable
  !! with covariance B from the standard normal distribution.
  !! Since any decomposition of the form LL^t can be used.
  !! This should be corrected in the future to apply the square root
  !! That can also be used for the multivariate random numbers generation.
  !! It has an overhead computation with the application of U^t.
  !<
  interface cov_square_mv
    module procedure cov_square_mv_default
    !module procedure cov_square_mv_1d
    module procedure cov_square_mv_2fac
    module procedure cov_square_mv_3fac
  end interface cov_square_mv

  !> square root covariance matrix vector product (adjoint)
  interface cov_square_mvb
    module procedure cov_square_mvb_default
    module procedure cov_square_mvb_2fac
    !module procedure cov_square_mv_3fac
  end interface cov_square_mvb

  !> Inverse square root covariance matrix vector product
  interface cov_square_inv_mv
    module procedure cov_square_inv_mv_default
    module procedure cov_square_inv_mv_2fac
    module procedure cov_square_inv_mv_3fac
  end interface cov_square_inv_mv

  !> Checks the parameters for the application of the covariance matrix
  !! or its inverse
  interface cov_mv_check
    module procedure cov_mv_check_default
    module procedure cov_mv_check_2fac
    module procedure cov_mv_check_3fac
  end interface cov_mv_check

  !> Check the parameters for the application of the square root of the
  !! covariance matrix or its inverse
  interface cov_square_mv_check
    module procedure cov_square_mv_check_default
    module procedure cov_square_mv_check_2fac
    module procedure cov_square_mv_check_3fac
  end interface cov_square_mv_check
!end of private procedures interface

contains

!public procedures

  !> \brief returns the number of singular values used to define the
  !!  approximation of the covariance matrix; that is also the size of
  !!  the changed state variable
  !! @param [in] C covariance matrix derived type
  !! @param [in] [nctl] size of the control vector
  !! @details
  !! If a call to load_covariance has not been done before: the function
  !! returns nctl if it is provided, otherwise, the program is stopped.
  !! If a call to load_covariance have been done before, the associated value
  !! is returned
  !<
  FUNCTION get_evd_cov_nsv(C, nctl) RESULT(nsv)
    type(evd_cov_matrix), intent(in) :: C
    INTEGER, OPTIONAL, INTENT(IN) :: nctl
    !local variables
    INTEGER :: nsv

    SELECT CASE(C%im_nFac)
      CASE (1)
        nsv = SIZE(C%Dx)
      CASE (2)
        nsv = SIZE(C%Dx)*SIZE(C%Dy)
      CASE (3)
        nsv = SIZE(C%Dx)*SIZE(C%Dy)*SIZE(C%Dz)
      CASE (default_nFact)!default value
        IF( PRESENT(nctl) )THEN
          nsv = nctl
        ELSE
          CALL stop_program( 'In evd_cov_nsv, covariance not loaded and nctl not provided' )
        END IF
      CASE DEFAULT
        CALL stop_program( 'In evd_cov_nsv, covariance operations are define only for 1D and 2D' )
    END SELECT
  END FUNCTION get_evd_cov_nsv

  !> \brief returns the number of rows of the covariance matrix
  !! @param [in] C covariance matrix derived type
  !!
  !! \details If \a C is not initialized, the program program stops.
  !<
  FUNCTION get_evd_cov_nRow(C) RESULT(nRow)
    type(evd_cov_matrix), intent(in) :: C
    !local variables
    INTEGER :: nRow

    SELECT CASE(C%im_nFac)
      CASE (1)
        nRow = SIZE(C%Ux, 1)
      CASE (2)
        nRow = SIZE(C%Ux, 1)*SIZE(C%Uy, 1)
      CASE (3)
        nRow = SIZE(C%Ux, 1)*SIZE(C%Uy, 1)*SIZE(C%Uz, 1)
      CASE DEFAULT
        CALL stop_program( 'In get_evd_cov_nRow, covariance not initialized' )
    END SELECT
  END FUNCTION get_evd_cov_nRow

  !> \brief Reads a covariance matrix stored under the form of an evd decomposition
  !! @param [in] UFName file name of the matrix of singular vectors
  !! @param [in] DFName file name of the matrix of singular values
  !! @param [in, out] U matrix of singular vectors
  !! @param [in, out] D vector of singular values
  !<
  SUBROUTINE readEVD( UFName, DFName, U, D )
    CHARACTER(len=*), INTENT(IN)  :: UFName, DFName
    REAL(cp), DIMENSION(:,:), INTENT(INOUT) :: U
    REAL(cp), DIMENSION(:), INTENT(INOUT) :: D
    !local variables
    REAL(cp), DIMENSION(:,:), ALLOCATABLE :: T
    INTEGER :: il_n, il_k, il_nRow, il_nCol, ibj

    CALL readEVDSize( UFName, DFName, il_n, il_k, il_nRow, il_nCol )
    ALLOCATE( T(il_nRow, il_nCol) )

    CALL readMatrix( UFName, U )
    CALL readMatrix( DFName, T )

    IF(il_nRow == 1) THEN
      D = T(1,:)
    ELSE IF(il_nCol == 1) THEN
      D = T(:,1)
    ELSE
      DO ibj = 1, il_nCol
        D(ibj) = T( ibj, ibj )
      END DO
    END IF
  END SUBROUTINE readEVD

  !> \brief read the size of the EV decomposition of B: size of each singular
  !!   vector, and number of singular vector
  !! @param [in] UFName file name of the matrix of singular vectors
  !! @param [in] DFName file name of the matrix of singular values
  !! @param [in, out] n size of each singular vector (number of rows/colums of B)
  !! @param [in, out] k number of singular values (or vector)
  !! @param [in, out] nrD (optional) number of rows of D
  !! @param [in, out] ncD (optional) number of colums of D
  !! if the sizes in UFName and DFName do not match, the program terminates
  !<
  SUBROUTINE readEVDSize(UFName, DFName, n, k, nrD, ncD)
    CHARACTER(len=*), INTENT(IN)  :: UFName, DFName
    INTEGER, INTENT(OUT) :: n, k
    INTEGER, OPTIONAL, INTENT(OUT) :: nrD, ncD
    INTEGER :: il_nrD, il_ncD

    CALL readInfo( UFName, n, k )
    CALL readInfo( DFName, il_nrD, il_ncD )
    CALL EVD_check( n, k, il_nrD, il_ncD )
    IF( PRESENT(nrD) ) nrD = il_nrD
    IF( PRESENT(ncD) ) ncD = il_ncD
  END SUBROUTINE readEVDSize

  !> \brief Loads the covariance matrix represented by its singular value
  !!   decomposition
  !! @param [in, out] C covariance matrix derived type
  !! @param [in] dir directory containing the data files
  !!
  !! \details It is assumed that the covariance matrix B is provided as
  !! its Singular Value Decomposition: B = UDU^t. Furthermore, it can
  !! be (Kronecker) factorized (for example along the physical dimensions of
  !! the problem) in which case it is given under the form:
  !! - B = Bx kron By = (UxDxUx^t) kron (UyDyUy^t) or
  !! - B = Bx kron By kron Bz = (UxDxUx^t) kron (UyDyUy^t) kron (UzDzUz^t)
  !! Conventions for the file names. Data files are named after the matrices
  !! names with the extension 'dat'
  !! - 'U.dat' and 'D.dat' for the non factorized case
  !! - 'Ux.dat',  'Uy.dat', 'Uz.dat' and 'Dx.dat', 'Dy.dat', 'Dz.dat' for
  !!   the factorized case
  !! the existence of files is checked to determine the appropriate configuration.
  !! ('U.dat' and 'D.dat') or ('Ux.dat' and 'Dx.dat') should be present,
  !! otherwise the program terminates
  !!
  !<
  SUBROUTINE load_evd_covariance(C, dir)
    type(evd_cov_matrix), intent(in out) :: C
    CHARACTER(len=*), INTENT(IN)  :: dir
    !local variables
    INTEGER :: il_N, il_K
    CHARACTER(len=ip_fnl) :: UFName, DFName

    CALL debug('Entering load_covariance ', tag=dALLWAYS )
    !Checking files
    IF( fileExist(TRIM(dir)//'/U.dat'))THEN
      UFName = TRIM(dir)//'/U.dat'
      DFName = TRIM(dir)//'/D.dat'
    ELSE
      UFName = TRIM(dir)//'/Ux.dat'
      DFName = TRIM(dir)//'/Dx.dat'
    END IF

    CALL debug(100, ' In load_evd_covariance ', tag=dALLWAYS )
    CALL readEVDSize(UFName, DFName, il_N, il_K)
    ALLOCATE( C%Ux(il_N, il_K), C%Dx(il_K) )
    CALL readEVD( UFName, DFName, C%Ux, C%Dx )
    CALL debug(C%Ux, 'Ux = ')
    CALL debug(C%Dx, 'Dx = ')
    C%im_nFac = 1

    CALL debug(200, ' In load_evd_covariance ', tag=dALLWAYS )
    UFName = TRIM(dir)//'/Uy.dat'
    DFName = TRIM(dir)//'/Dy.dat'
    IF( fileExist(uFName) )THEN
      CALL readEVDSize(UFName, DFName, il_N, il_K)
      ALLOCATE( C%Uy(il_N, il_K), C%Dy(il_K) )
      CALL readEVD( UFName, DFName, C%Uy, C%Dy )
      CALL debug(C%Uy, 'Uy = ')
      CALL debug(C%Dy, 'Dy = ')
      C%im_nFac = C%im_nFac + 1
    END IF

    CALL debug('Exiting load_evd_covariance ', tag=dALLWAYS )
  END SUBROUTINE load_evd_covariance

  !> \brief Writes a covariance matrix under the form of an eigenvalues
  !!  decomposition
  !! @param [in] UFName file name of the matrix of singular vectors
  !! @param [in] DFName file name of the vector(matrix) of singular values
  !! @param [in, out] U matrix of singular vectors
  !! @param [in, out] D vector of singular values
  !<
  subroutine writeEVD( UFName, DFName, U, D )
    character(len=*), intent(in)  :: UFName, DFName
    real(cp), dimension(:,:), intent(in) :: U
    real(cp), dimension(:), intent(in) :: D
    !local variables
    real(cp), dimension(size(D),1) :: T

    T(:,1) = D

    call writeMatrix( UFName, U )
    call writeMatrix( DFName, T )
  end subroutine writeEVD

  !> \brief Saves the covariance matrix represented by its eigenvalues
  !!  decomposition
  !! @param [in] C covariance matrix derived type
  !! @param [in] dir directory where the data files will be created
  !! @see load_evd_covariance
  !<
  subroutine save_evd_covariance(C, dir)
    type(evd_cov_matrix), intent(in) :: C
    character(len=*), intent(in)  :: dir
    !local variables
    character(len=ip_fnl) :: UFName, DFName

    call debug('Entering save_evd_covariance ', tag=dALLWAYS )
    !Checking files
    if( C%im_nFac == 1 )then
      UFName = TRIM(dir)//'/U.dat'
      DFName = TRIM(dir)//'/D.dat'
    else if ( C%im_nFac > 1 )then
      UFName = TRIM(dir)//'/Ux.dat'
      DFName = TRIM(dir)//'/Dx.dat'
    else if ( C%im_nFac < 1 )then
      call stop_program('can not save uninitialized covariance matrix')
    end if

    call debug(100, ' In save_evd_covariance ', tag=dALLWAYS )
    call writeEVD( UFName, DFName, C%Ux, C%Dx )

    call debug(200, ' In save_evd_covariance ', tag=dALLWAYS )
    if( C%im_nFac>=2 )then
      UFName = TRIM(dir)//'/Uy.dat'
      DFName = TRIM(dir)//'/Dy.dat'
      call writeEVD( UFName, DFName, C%Uy, C%Dy )
    end if

    call debug(300, ' In save_evd_covariance ', tag=dALLWAYS )
    if( C%im_nFac>=3 )then
      UFName = trim(dir)//'/Uz.dat'
      DFName = trim(dir)//'/Dz.dat'
      call writeEVD( UFName, DFName, C%Uz, C%Dz )
    end if

    call debug('Exiting save_evd_covariance ', tag=dALLWAYS )
  end subroutine save_evd_covariance

  !> Gets the sizes of the factorized arrays that make up the EV decomposed
  !! covariance matrix
  !! @param [in] C covariance matrix derived type
  !! @param [out] Nx number of components [in the x direction]
  !! @param [out] Kx number of singular vectors [in the x direction]
  !! @param [out] Ny number  of components in the y direction
  !! @param [out] Ky number of singular vectors in the y direction
  !! @param [out] Nz number  of components in the z direction
  !! @param [out] Kz number of singular vectors in the z direction
  !!
  !! \details Negatives value means that there is no component in the given
  !!  direction.
  !<
  subroutine get_evd_cov_size(C, Nx, Kx, Ny, Ky, Nz, Kz)
    type(evd_cov_matrix), intent(in out) :: C
    INTEGER, INTENT(OUT), OPTIONAL :: Nx, Kx, Ny, Ky, Nz, Kz

    if(C%im_nFac>=1)then
      if( present(Nx) )Nx = size(C%Ux,1)
      if( present(Kx) )Kx = size(C%Ux,2)
    else
      if( present(Nx) )Nx = -1
      if( present(Kx) )Kx = -1
    end if

    if(C%im_nFac>=2)then
      if( present(Ny) )Ny = size(C%Uy,1)
      if( present(Ky) )Ky = size(C%Uy,2)
    else
      if( present(Ny) )Ny = -1
      if( present(Ky) )Ky = -1
    end if

    if(C%im_nFac>=3)then
      if( present(Nz) )Nz = size(C%Uz,1)
      if( present(Kz) )Kz = size(C%Uz,2)
    else
      if( present(Nz) )Nz = -1
      if( present(Kz) )Kz = -1
    end if
  end subroutine get_evd_cov_size

  !> \brief applies the covariance matrix to the vector f, g = Bf
  !! @param [in] C covariance matrix derived type
  !! @param [in] f input vector
  !! @param [in] g output vector
  !! @param [in] [die] specify the behavior of the program if the covariance
  !!  matrix is not loaded. if TRUE, the program stops, otherwise g =f.
  !!  The user should make sure that f and g have the same size.
  !<
  SUBROUTINE apply_evd_cov(C, f, g, die)
    type(evd_cov_matrix), intent(in) :: C
    REAL(cp), DIMENSION(:), INTENT(IN)  :: f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL, OPTIONAL, INTENT(IN) :: die
    !local variables
    LOGICAL :: ll_die

    IF( PRESENT(die) )THEN
      ll_die = die
    ELSE
      ll_die = .TRUE.
    END IF

    SELECT CASE(C%im_nFac)
      CASE (1)
        CALL cov_mv(C%Ux, C%Dx, f, g)
      CASE (2)
        CALL cov_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
      CASE (3)
        CALL cov_mv(C%Ux, C%Dx, C%Uy, C%Dy, C%Uz, C%Dz, f, g)
      CASE (default_nFact)!default value
        IF(ll_die)THEN
          CALL stop_program('In apply_evd_cov covariance matrix is not loaded')
        ELSE
          g=f
        END IF
       case default
          call debug(C%im_nFac, "Number of factor: ")
          CALL stop_program('In apply_evd_cov covariance matrix is not supported')
    END SELECT
  END SUBROUTINE apply_evd_cov

  !> \brief applies the inverse of covariance matrix, g = B^-1 f
  !! @param [in] C covariance matrix derived type
  !! @param [in] f input vector
  !! @param [in] g output vector
  !! @param [in] [die] specify the behaviour of the program if the covariance
  !!   matrix is not loaded. if TRUE, the program stops, otherwise g =f.
  !!   The user should make sure that f and g have the same size.
  !<
  SUBROUTINE apply_evd_cov_inv(C, f, g, die)
    type(evd_cov_matrix), intent(in) :: C
    REAL(cp), DIMENSION(:), INTENT(IN)  :: f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL, OPTIONAL, INTENT(IN) :: die
    !local variables
    LOGICAL :: ll_die

    IF( PRESENT(die) )THEN
      ll_die = die
    ELSE
      ll_die = .TRUE.
    END IF

    SELECT CASE(C%im_nFac)
      CASE (1)
        CALL cov_inv_mv(C%Ux, C%Dx, f, g)
      CASE (2)
        CALL cov_inv_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
      CASE (3)
        CALL cov_inv_mv(C%Ux, C%Dx, C%Uy, C%Dy, C%Uz, C%Dz, f, g)
      CASE default!default value
        IF(ll_die)THEN
          CALL stop_program('In apply_evd_cov_inv covariance matrix is not loaded')
        ELSE
          g=f
        END IF
    END SELECT
  END SUBROUTINE apply_evd_cov_inv

  !> \brief apply the square root of the covariance matrix to the vector f and
  !!  result g
  !! @param [in] C covariance matrix derived type
  !! @param [in] f input vector
  !! @param [in] g output vector
  !! @param [in] [die] specify the behaviour of the program if the covariance
  !!   matrix is not loaded. if TRUE, the program stops, otherwise g =f,
  !!   the user should make sure that f and g have the same size.
  !<
  SUBROUTINE apply_evd_square_cov(C, f, g, die)
    type(evd_cov_matrix), intent(in) :: C
    REAL(cp), DIMENSION(:), INTENT(IN)  :: f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL, OPTIONAL, INTENT(IN) :: die
    !local variables
    LOGICAL :: ll_die

    IF( PRESENT(die) )THEN
      ll_die = die
    ELSE
      ll_die = .TRUE.
    END IF

    SELECT CASE(C%im_nFac)
      CASE (1)
        CALL cov_square_mv(C%Ux, C%Dx, f, g)
      CASE (2)
        CALL cov_square_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
      CASE (3)
        CALL cov_square_mv(C%Ux, C%Dx, C%Uy, C%Dy, C%Uz, C%Dz, f, g)
      CASE default!default value
        IF(ll_die)THEN
          CALL stop_program('In apply_evd_square_cov, covariance matrix is not loaded/supported')
        ELSE
          g=f
        END IF
    END SELECT
  END SUBROUTINE apply_evd_square_cov

  !> \brief apply the adjoint of the square root of the covariance matrix to
  !!   the vector f and result g
  !! @param [in] C covariance matrix derived type
  !! @param [in] fb input vector
  !! @param [in] gb output vector
  !! @param [in] [die] specify the behaviour of the program if the covariance
  !!   matrix is not loaded. if TRUE, the program stops, otherwise g =f.
  !!   The user should make sure that f and g have the same size.
  !<
  SUBROUTINE apply_evd_square_covb(C, fb, gb, die)
    type(evd_cov_matrix), intent(in) :: C
    REAL(cp), DIMENSION(:), INTENT(INOUT)  :: fb
    REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb
    LOGICAL, OPTIONAL, INTENT(IN) :: die
    !local variables
    LOGICAL :: ll_die

    IF( PRESENT(die) )THEN
      ll_die = die
    ELSE
      ll_die = .TRUE.
    END IF

    SELECT CASE(C%im_nFac)
      CASE (1)
        CALL cov_square_mvb(C%Ux, C%Dx, fb, gb)
      CASE (2)
        CALL cov_square_mvb(C%Ux, C%Dx, C%Uy, C%Dy, fb, gb)
      CASE default !default value
        IF(ll_die)THEN
          CALL stop_program('In apply_evd_square_covb, covariance matrix is not loaded/supported')
        ELSE
          fb=fb+gb
          gb=0.0_cp
        END IF
    END SELECT
  END SUBROUTINE apply_evd_square_covb

  !> \brief apply the inverse of the square root of the covariance matrix
  !!   to the vector f and result g
  !! @param [in] C covariance matrix derived type
  !! @param [in] f input vector
  !! @param [in] g output vector
  !! @param [in] [die] specify the behaviour of the program if the covariance
  !!   matrix is not loaded. if TRUE, the program stops, otherwise g =f.
  !!   The user should make sure that f and g have the same size.
  !<
  SUBROUTINE apply_evd_square_cov_inv(C, f, g, die)
    type(evd_cov_matrix), intent(in) :: C
    REAL(cp), DIMENSION(:), INTENT(IN)  :: f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL, OPTIONAL, INTENT(IN) :: die
    !local variables
    LOGICAL :: ll_die

    IF( PRESENT(die) )THEN
      ll_die = die
    ELSE
      ll_die = .TRUE.
    END IF

    SELECT CASE(C%im_nFac)
      CASE (1)
        CALL cov_square_inv_mv( C%Ux, C%Dx, f, g )
      CASE (2)
        CALL cov_square_inv_mv( C%Ux, C%Dx, C%Uy, C%Dy, f, g )
      CASE (3)
        CALL cov_square_inv_mv( C%Ux, C%Dx, C%Uy, C%Dy, C%Uz, C%Dz, f, g )
      CASE ( default_nFact )!default value
        IF (ll_die) THEN
          CALL stop_program('In apply_evd_square_cov_inv, covariance matrix is not loaded')
        ELSE
          g=f
        END IF
    END SELECT
  END SUBROUTINE apply_evd_square_cov_inv

  !> @brief Makes a EVD covariance matrix
  !! @param [in, out] C is an evd covariance matrix data structure
  !! @param [in] xcp covariance parameters in the x dimension
  !! @param [in] ycp covariance parameters in the y dimension
  !! @param [in] zcp covariance parameters in the z dimension
  !!
  !! @details zcp is processed only if ycp is present
  !<
  subroutine make_evd_cov(C, xcp, ycp, zcp )
    type(evd_cov_matrix), intent(in out) :: C
    type(exp_cov_param), intent(in) :: xcp
    type(exp_cov_param), optional, intent(in) :: ycp, zcp
    !local variables
    real(dp), dimension(:,:), allocatable :: A

    allocate( A(xcp%n, xcp%n), C%Ux(xcp%n, xcp%k), C%Dx(xcp%k) )
    call se_cov_matrix(A, xcp)
    !call debug(A, 'in  make_evd_cov, Cx = ')
    call symmetric_ev(A, xcp%k, C%Ux, C%Dx)
    deallocate(A)
    C%im_nFac = 1

    if(present(ycp))then
      allocate( A(ycp%n, ycp%n), C%Uy(ycp%n, ycp%k), C%Dy(ycp%k) )
      call se_cov_matrix(A, ycp)
      call symmetric_ev(A, ycp%k, C%Uy, C%Dy)
      deallocate(A)
      C%im_nFac = C%im_nFac + 1
      if(present(zcp))then
        allocate( A(zcp%n, zcp%n), C%Uz(zcp%n, zcp%k), C%Dz(zcp%k) )
        call se_cov_matrix(A, zcp)
        call symmetric_ev(A, zcp%k, C%Uz, C%Dz)
        deallocate(A)
        C%im_nFac = C%im_nFac + 1
      end if
    else
      if(present(zcp))then
        call stop_program("In make_evd_cov: z is present and y is absent")
      end if
    end if

  end subroutine make_evd_cov

!end of public procedures

!privates procedures
  !> \brief Checks the parameters for the application of the covariance matrix
  !!  or its inverse
  !! @see cov_mv_2Fac for the description of the parameters
  !<
  SUBROUTINE cov_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy
    real(cp), dimension(:), intent(in)  :: Dx, Dy, f
    real(cp), dimension(:), intent(in) :: g
    !local variables
    INTEGER :: nx, ny, kx, ky, nf_predict

    nx = SIZE(Ux,1)
    ny = SIZE(Uy,1)
    kx = SIZE(Ux,2)
    ky = SIZE(Uy,2)
    nf_predict = nx*ny
    if( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=nf_predict) )THEN
      call debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
      call debug(kx, 'Dx of size :', tag=dALLWAYS)
      call debug(ky, 'Dy of size :', tag=dALLWAYS)
      call debug(nf_predict, 'f and g of size :', tag=dALLWAYS)
      call debug('Get the following, check and try aigain', tag=dALLWAYS)
      call debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
      call debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
      call debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      call debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      call debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      call debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
      call debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
      call stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    end if
  end subroutine cov_mv_check_2Fac
  !> \brief Checks the parameters for the application of the covariance matrix
  !!  or its inverse
  !! @see cov_mv_3Fac for the description of the parameters
  !<
  SUBROUTINE cov_mv_check_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy, Uz
    real(cp), dimension(:), intent(in)  :: Dx, Dy, Dz, f
    real(cp), dimension(:), intent(in) :: g
    !local variables
    INTEGER :: nx, ny, nz, kx, ky, kz, nf_predict

    nx = size(Ux,1)
    ny = size(Uy,1)
    nz = size(Uz,1)
    kx = size(Ux,2)
    ky = size(Uy,2)
    kz = size(Uz,2)
    nf_predict = nx*ny*nz
    if( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(Dz)/=kz)&
        .OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=nf_predict) )THEN
      call debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
      call debug(kx, 'Dx of size :', tag=dALLWAYS)
      call debug(ky, 'Dy of size :', tag=dALLWAYS)
      call debug(kz, 'Dz of size :', tag=dALLWAYS)
      call debug(nf_predict, 'f and g of size :', tag=dALLWAYS)
      call debug('Get the following, check and try aigain', tag=dALLWAYS)
      call debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
      call debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
      call debug(SIZE(Dz), 'SIZE(Dz)', tag=dALLWAYS)
      call debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      call debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      call debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      call debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
      call debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
      call debug(SHAPE(Uz), 'SHAPE(Uz)', tag=dALLWAYS)
      call stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    end if
  end subroutine cov_mv_check_3Fac

  !> @brief multiply a vector by the covariance matrix given as a Kronecker
  !!   product of two covariance Bx and By. Each one being given by its EVD.
  !!   Best suited for two physical dimensions problems where the covariance
  !!   factorizes.
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] f input vector of size nx*ny (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny
  !! @details
  !! computes g = Bf
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  subroutine cov_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy
    real(cp), dimension(:), intent(in)  :: Dx, Dy, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    real(cp), dimension( SIZE(Dx)*SIZE(Dy) ) :: t1, t2

    !checking the input parameters
    call cov_mv_check(Ux, Dx, Uy, Dy, f, g)

    call kron_matvec(Ux, Uy, f , t1, trans=.TRUE.)
    call kron_matvec(Dx, Dy, t1, t2)
    call kron_matvec(Ux, Uy, t2, g , trans=.FALSE.)
  end subroutine cov_mv_2Fac

  !> @brief multiply a vector by the covariance matrix given as a Kronecker
  !!   product of 3 covariance Bx, By, Bz. Each one being given by its EVD.
  !!   Best suited for two physical dimensions problems where the covariance
  !!   factorizes.
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] Uz matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix By in the direction y, size (nz, kz)
  !! @param[in] Dz vector of leading eigenvalues in the direction z, size kz
  !! @param[in] f input vector of size nx*ny*nz (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny*nz
  !! @details
  !! computes g = Bf
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  subroutine cov_mv_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy, Uz
    real(cp), dimension(:), intent(in)  :: Dx, Dy, Dz, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    real(cp), dimension( SIZE(Dx)*SIZE(Dy)*SIZE(Dz) ) :: t1, t2

    !checking the input parameters
    call cov_mv_check(Ux, Dx, Uy, Dy, Uz, Dz, f, g)

    call kron_matvec(Ux, Uy, Uz, f , t1, trans=.TRUE.)
    call kron_matvec(Dx, Dy, Dz, t1, t2)
    call kron_matvec(Ux, Uy, Uz, t2, g , trans=.FALSE.)
  end subroutine cov_mv_3Fac

  !> \brief Checks the parameters for the application of the covariance matrix
  !!   or its inverse
  !! @see cov_mv_2Fac for the description of the parameters
  !<
  subroutine cov_mv_check_default(U, D, f, g)
    real(cp), dimension(:,:), intent(in) :: U
    real(cp), dimension(:), intent(in)  :: D, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    integer :: n, k

    n = SIZE(U,1)
    k = SIZE(U,2)
    if( (SIZE(D)/=k).OR.(SIZE(f)/=n).OR.(SIZE(g)/=n) )THEN
      call debug('cov_mv_check_default: Expecting data with following specification, based on the shape of U', tag=dALLWAYS)
      call debug(k, 'D of size :', tag=dALLWAYS)
      call debug(n, 'f and g of size :', tag=dALLWAYS)
      call debug('Get the following, check and try aigain', tag=dALLWAYS)
      call debug(SIZE(D), 'SIZE(D)', tag=dALLWAYS)
      call debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      call debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      call debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      call debug(SHAPE(U), 'SHAPE(U)', tag=dALLWAYS)
      call stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    end if
  end subroutine cov_mv_check_default

  !> @brief multiply a vector by the covariance matrix given as its EVD
  !! @param[in] U matrix whose columns are the leading eigenvectors of the
  !!   covariance matrix B, size (n, k)
  !! @param[in] D vector of leading eigenvalues, size k
  !! @param[in] f input vector of size n (size of the discretization grid)
  !! @param[out] g output vector of size n
  !! @details
  !! computes g = Bf
  !<
  subroutine cov_mv_default(U, D, f, g)
    real(cp), dimension(:,:), intent(in) :: U
    real(cp), dimension(:), intent(in)  :: D, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    REAL(cp), DIMENSION( SIZE(D) ) :: t1, t2

    !checking the input parameters
    CALL cov_mv_check( U, D, f, g )

    t1 = MATMUL(f, U) !transpose
    t2 = D*t1
    g  = MATMUL(U, t2)
  end subroutine cov_mv_default

  !> \brief multiplies a vector by the inverse of the covariance matrix,
  !!   two physical dimensions problem
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] f input vector of size nx*ny (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny
  !! \details
  !! computes g = B^-1 f
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  SUBROUTINE cov_inv_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    REAL(cp), DIMENSION(SIZE(Dx)) :: DxInv
    REAL(cp), DIMENSION(SIZE(Dy)) :: DyInv
    REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t1, t2

    !checking the input parameters
    CALL cov_mv_check(Ux, Dx, Uy, Dy, f, g)

    DxInv = 1.0/Dx
    DyInv = 1.0/Dy
    CALL kron_matvec(Ux, Uy, f , t1, trans=.TRUE.)
    CALL kron_matvec(DxInv, DyInv, t1, t2)
    CALL kron_matvec(Ux, Uy, t2, g , trans=.FALSE.)
  END SUBROUTINE cov_inv_mv_2Fac

  !> @brief multiplies a vector by the inverse of the covariance matrix,
  !!   3 physical dimensions problem
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] Uz matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix By in the direction y, size (nz, kz)
  !! @param[in] Dz vector of leading eigenvalues in the direction z, size kz
  !! @param[in] f input vector of size nx*ny*nz (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny*nz
  !! @details
  !! computes g = Bf
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  SUBROUTINE cov_inv_mv_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy, Uz
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, Dz, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    REAL(cp), DIMENSION(SIZE(Dx)) :: DxInv
    REAL(cp), DIMENSION(SIZE(Dy)) :: DyInv
    REAL(cp), DIMENSION(SIZE(Dz)) :: DzInv
    REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy)*SIZE(Dz) ) :: t1, t2

    !checking the input parameters
    CALL cov_mv_check(Ux, Dx, Uy, Dy, Uz, Dz, f, g)

    DxInv = 1.0/Dx
    DyInv = 1.0/Dy
    DzInv = 1.0/Dz
    CALL kron_matvec(Ux, Uy, Uz, f , t1, trans=.TRUE.)
    CALL kron_matvec(DxInv, DyInv, DzInv, t1, t2)
    CALL kron_matvec(Ux, Uy, Uz, t2, g , trans=.FALSE.)
  END SUBROUTINE cov_inv_mv_3Fac

  !> \brief multiplies a vector by the inverse of the covariance matrix given
  !!   as its EVD
  !! @param[in] U matrix whose columns are the leading eigenvalues vector of
  !!   the covariance matrix B, size (n, k)
  !! @param[in] D vector of leading eigenvalues, size k
  !! @param[in] f input vector of size n (size of the discretization grid)
  !! @param[out] g output vector of size n
  !! \details
  !! computes g = B^-1 f
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  SUBROUTINE cov_inv_mv_default(U, D, f, g)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
    REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    REAL(cp), DIMENSION(SIZE(D)) :: t1, t2

    !checking the input parameters
    CALL cov_mv_check( U, D, f, g )

    t1 = MATMUL(f, U) !transpose
    t2 = t1/D
    g  = MATMUL(U, t2)
  END SUBROUTINE cov_inv_mv_default

  !> \brief Checks the parameters for the application of the square root of
  !!  the covariance matrix or its inverse
  !! @see cov_square_mv_default for the description of the parameters
  !<
  SUBROUTINE cov_square_mv_check_default(U, D, f, g, inv)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
    REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL, OPTIONAL :: inv
    !local variables
    INTEGER :: n, k, nf_predict, ng_predict
    LOGICAL :: ll_inv

    IF( PRESENT(inv) )THEN
      ll_inv = inv
    ELSE
      ll_inv = .FALSE.
    END IF
    n = SIZE(U,1)
    k = SIZE(U,2)
    IF(ll_inv)THEN
      nf_predict = n
      ng_predict = k
    ELSE
      nf_predict = k
      ng_predict = n
    END IF
    IF( (SIZE(D)/=k).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=ng_predict) )THEN
      CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
      CALL debug(k, 'D of size :', tag=dALLWAYS)
      CALL debug(nf_predict, 'f of size :', tag=dALLWAYS)
      CALL debug(ng_predict, 'g of size :', tag=dALLWAYS)
      CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
      CALL debug(SIZE(D), 'SIZE(Dx)', tag=dALLWAYS)
      CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      CALL debug(SHAPE(U), 'SHAPE(U)', tag=dALLWAYS)
      IF(ll_inv) CALL debug('The purpose is to compute apply the inverse square root', tag=dALLWAYS)
      CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    END IF
  END SUBROUTINE cov_square_mv_check_default

  !> \brief Checks the parameters for the application of the square root
  !!   of the covariance matrix or its inverse
  !! @see cov_square_mv_2Fac for the description of the parameters
  !<
  SUBROUTINE cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
    REAL(cp), DIMENSION(:), INTENT(IN) :: g
    LOGICAL, OPTIONAL :: inv
    !local variables
    INTEGER :: nx, ny, kx, ky, nf_predict, ng_predict
    LOGICAL :: ll_inv

    IF( PRESENT(inv) )THEN
      ll_inv = inv
    ELSE
      ll_inv = .FALSE.
    END IF
    nx = SIZE(Ux,1)
    ny = SIZE(Uy,1)
    kx = SIZE(Ux,2)
    ky = SIZE(Uy,2)
    IF(ll_inv)THEN
      nf_predict = nx*ny
      ng_predict = kx*ky
    ELSE
      nf_predict = kx*ky
      ng_predict = nx*ny
    END IF
    IF( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=ng_predict) )THEN
      CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
      CALL debug(kx, 'Dx of size :', tag=dALLWAYS)
      CALL debug(ky, 'Dy of size :', tag=dALLWAYS)
      CALL debug(nf_predict, 'f of size :', tag=dALLWAYS)
      CALL debug(ng_predict, 'g of size :', tag=dALLWAYS)
      CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
      CALL debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
      CALL debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
      CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      CALL debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
      CALL debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
      IF(ll_inv) CALL debug('The purpose is to apply the inverse square root', tag=dALLWAYS)
      CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    END IF
  END SUBROUTINE cov_square_mv_check_2Fac

  !> \brief Checks the parameters for the application of the square root
  !!   of the covariance matrix or its inverse
  !! @see cov_square_mv_3Fac for the description of the parameters
  !<
  SUBROUTINE cov_square_mv_check_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g, inv)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy, Uz
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, Dz, f
    REAL(cp), DIMENSION(:), INTENT(IN) :: g
    LOGICAL, OPTIONAL :: inv
    !local variables
    INTEGER :: nx, ny, nz, kx, ky, kz, nf_predict, ng_predict
    LOGICAL :: ll_inv

    IF( PRESENT(inv) )THEN
      ll_inv = inv
    ELSE
      ll_inv = .FALSE.
    END IF
    nx = SIZE(Ux,1)
    ny = SIZE(Uy,1)
    nz = SIZE(Uz,1)
    kx = SIZE(Ux,2)
    ky = SIZE(Uy,2)
    kz = SIZE(Uz,2)
    IF(ll_inv)THEN
      nf_predict = nx*ny*nz
      ng_predict = kx*ky*kz
    ELSE
      nf_predict = kx*ky*kz
      ng_predict = nx*ny*nz
    END IF
    IF( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(Dz)/=kz)&
        .OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=ng_predict) )THEN
      CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
      CALL debug(kx, 'Dx of size :', tag=dALLWAYS)
      CALL debug(ky, 'Dy of size :', tag=dALLWAYS)
      CALL debug(kz, 'Dz of size :', tag=dALLWAYS)
      CALL debug(nf_predict, 'f of size :', tag=dALLWAYS)
      CALL debug(ng_predict, 'g of size :', tag=dALLWAYS)
      CALL debug('Got the following, check and try aigain', tag=dALLWAYS)
      CALL debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
      CALL debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
      CALL debug(SIZE(Dz), 'SIZE(Dz)', tag=dALLWAYS)
      CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
      CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the shapes of Ux, Uy, Uz', tag=dALLWAYS)
      CALL debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
      CALL debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
      CALL debug(SHAPE(Uz), 'SHAPE(Uz)', tag=dALLWAYS)
      IF(ll_inv) CALL debug('The purpose is to apply the inverse square root', tag=dALLWAYS)
      CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
    END IF
  END SUBROUTINE cov_square_mv_check_3Fac

    !> \brief multiplies a vector by the square root of the covariance matrix
    !!  given as its EVD
    !! @param[in] U matrix whose columns are the leading eigenvalues vector
    !!   of the covariance matrix B, size (n, k)
    !! @param[in] D vector of leading eigenvalues, size k
    !! @param[in] f input vector of size k (size of the discretization grid)
    !! @param[out] g output vector of size n
    !! \details
    !! computes g = B^0.5 f
    !<
    SUBROUTINE cov_square_mv_default(U, D, f, g)
        REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
        REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
        REAL(cp), DIMENSION(:), INTENT(OUT) :: g
        !local variables
        REAL(cp), DIMENSION( SIZE(D) ) :: t

        !checking the input parameters
        CALL cov_square_mv_check(U, D, f, g, inv=.FALSE.)

        t = SQRT(D)*f
        g = MATMUL(U, t)
    END SUBROUTINE cov_square_mv_default

    !> \brief multiplies a vector by the square root of the covariance matrix,
    !!  two physical dimensions problem
    !! @param[in] Ux matrix whose columns are the leading eigenvalues vector
    !!   of the covariance matrix Bx in the direction x, size (nx, kx)
    !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
    !! @param[in] Uy matrix whose columns are the leading eigenvalues vector
    !!   of the covariance matrix By in the direction y, size (ny, ky)
    !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
    !! @param[in] f input vector of size kx*ky (size of the discretization grid)
    !! @param[out] g output vector of size nx*ny
    !! \details
    !! computes g = B^0.5 f
    !! this routine assumes either :
    !! - the x-leading and and row major vectorization or
    !! - the y-leading and the column major vectorization
    !<
    SUBROUTINE cov_square_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
        REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
        REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
        REAL(cp), DIMENSION(:), INTENT(OUT) :: g
        !local variables
        REAL(cp), DIMENSION(SIZE(Dx)) :: Dx05
        REAL(cp), DIMENSION(SIZE(Dy)) :: Dy05
        REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t

        !checking the input parameters
        CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv=.FALSE.)

        Dx05 = SQRT(Dx)
        Dy05 = SQRT(Dy)
    !     call debug (Dx(size(Dx)-4:),'Dx = ', tag=dALLWAYS)
    !     call debug (Dy(size(Dy)-4:),'Dy = ', tag=dALLWAYS)
    !     call debug (Dx05(size(Dx05)-4:),'Dx05 = ', tag=dALLWAYS)
    !     call debug (Dy05(size(Dy05)-4:),'Dy05 = ', tag=dALLWAYS)
    !
    !     call debug (Dx(1:5),'Dx = ', tag=dALLWAYS)
    !     call debug (Dy(1:5),'Dy = ', tag=dALLWAYS)
    !     call debug (Dx05(1:5),'Dx05 = ', tag=dALLWAYS)
    !     call debug (Dy05(1:5),'Dy05 = ', tag=dALLWAYS)

        CALL kron_matvec(Dx05, Dy05, f, t)
        !call debug (t(1:5),'t = ', tag=dALLWAYS)
        CALL kron_matvec(Ux, Uy, t, g , trans=.FALSE.)
        !call debug (g(1:5),'g = ', tag=dALLWAYS)
    END SUBROUTINE cov_square_mv_2Fac

  !> \brief multiplies a vector by the square root of the covariance matrix,
  !!  two physical dimensions problem
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] Uz matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix Bz in the direction z, size (nz, kz)
  !! @param[in] Dz vector of leading eigenvalues in the direction z, size kz
  !! @param[in] f input vector of size kx*ky*kz (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny*nz
  !! \details
  !! computes g = B^0.5 f
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the z-leading and the column major vectorization
  !<
  subroutine cov_square_mv_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy, Uz
    real(cp), dimension(:), intent(in)  :: Dx, Dy, Dz, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    real(cp), dimension(size(dx))       :: Dx05
    real(cp), dimension(size(dy))       :: Dy05
    real(cp), dimension(size(dz))       :: Dz05
    real(cp), dimension( size(Dx)*size(Dy)*size(Dz) ) :: t

    !checking the input parameters
    call cov_square_mv_check_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g, inv=.false.)

    Dx05 = sqrt(dx)
    dy05 = sqrt(Dy)
    dz05 = sqrt(Dz)

    call kron_matvec(Dx05, Dy05, Dz05, f, t)
    !call debug (t(1:5),'t = ', tag=dALLWAYS)
    call kron_matvec(Ux, Uy, Uz, t, g , trans=.false.)
    !call debug (g(1:5),'g = ', tag=dALLWAYS)
  end subroutine cov_square_mv_3Fac

  !> adjoint subroutine, used mathmatical formulation of the adjoint with
  !! linear operators
  !<
  SUBROUTINE cov_square_mvb_default(U, D, fb, gb)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
    REAL(cp), DIMENSION(:), INTENT(IN)  :: D
    REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb, fb
    !local variables
    REAL(cp), DIMENSION( SIZE(D) ) :: tb

    !checking the input parameters
    CALL cov_square_mv_check(U, D, fb, gb, inv=.FALSE.)

    tb = tb + MATMUL(gb, U)
    gb = 0.0_cp
    fb = fb + SQRT(D)*tb
    tb = 0.0_cp
  END SUBROUTINE cov_square_mvb_default

  !> adjoint subroutine, used mathmatical formulation of the adjoint with
  !! linear operators
  !<
  SUBROUTINE cov_square_mvb_2Fac(Ux, Dx, Uy, Dy, fb, gb)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy
    REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb, fb
    !local variables
    REAL(cp), DIMENSION(SIZE(Dx)) :: Dx05
    REAL(cp), DIMENSION(SIZE(Dy)) :: Dy05
    REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: tb
    REAL(cp), DIMENSION( SIZE(fb) ) :: tmp

    !checking the input parameters
    CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, fb, gb, inv=.FALSE.)
    !initialization

    Dx05 = SQRT(Dx)
    Dy05 = SQRT(Dy)

    CALL kron_matvec( Ux, Uy, gb, tb , trans=.TRUE. )!/!\optimised, knowing that tb is zero
    gb = 0.0_cp
    CALL kron_matvec( Dx05, Dy05, tb, tmp )! No need for transpose with diagonal square matrices
    fb = fb + tmp
    tb = 0.0_cp
  END SUBROUTINE cov_square_mvb_2Fac

  !> \brief multiplies a vector by the inverse of the square root of
  !!   the covariance matrix, two physical dimensions problem
  !! @param[in] Ux matrix whose columns are the leading eigenvalues
  !!   vector of the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues
  !!   vector of the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] f input vector of size nx*ny (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny
  !! \details
  !! computes g = B^-0.5 f
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the y-leading and the column major vectorization
  !<
  SUBROUTINE cov_square_inv_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
    REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    REAL(cp), DIMENSION(SIZE(Dx)) :: DxInv
    REAL(cp), DIMENSION(SIZE(Dy)) :: DyInv
    REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t

    !checking the input parameters
    CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv=.TRUE.)

    DxInv = SQRT(1.0/Dx)
    DyInv = SQRT(1.0/Dy)
    CALL kron_matvec(Ux, Uy, f, t , trans=.TRUE.)
    CALL kron_matvec(DxInv, DyInv, t, g)
  END SUBROUTINE cov_square_inv_mv_2Fac

  !> \brief multiplies a vector by the inverse of the square root of
  !!   the covariance matrix, 3 physical dimensions problem
  !! @param[in] Ux matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix Bx in the direction x, size (nx, kx)
  !! @param[in] Dx vector of leading eigenvalues in the direction x, size kx
  !! @param[in] Uy matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix By in the direction y, size (ny, ky)
  !! @param[in] Dy vector of leading eigenvalues in the direction y, size ky
  !! @param[in] Uz matrix whose columns are the leading eigenvalues vector
  !!   of the covariance matrix Bz in the direction z, size (nz, kz)
  !! @param[in] Dz vector of leading eigenvalues in the direction z, size kz
  !! @param[in] f input vector of size kx*ky*kz (size of the discretization grid)
  !! @param[out] g output vector of size nx*ny*nz
  !! \details
  !! computes g = B^-0.5 f
  !! this routine assumes either :
  !! - the x-leading and and row major vectorization or
  !! - the z-leading and the column major vectorization
  !<
  subroutine cov_square_inv_mv_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g)
    real(cp), dimension(:,:), intent(in) :: Ux, Uy, Uz
    real(cp), dimension(:), intent(in)  :: Dx, Dy, Dz, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    real(cp), dimension(size(dx))       :: DxInv
    real(cp), dimension(size(dy))       :: DyInv
    real(cp), dimension(size(dz))       :: DzInv
    real(cp), dimension( size(Dx)*size(Dy)*size(Dz) ) :: t

    !checking the input parameters
    call cov_square_mv_check_3Fac(Ux, Dx, Uy, Dy, Uz, Dz, f, g, inv=.false.)

    DxInv = SQRT(1.0/Dx)
    DyInv = SQRT(1.0/Dy)
    DzInv = SQRT(1.0/Dz)
    CALL kron_matvec(Ux, Uy, Uz, f, t , trans=.TRUE.)
    CALL kron_matvec(DxInv, DyInv, DzInv, t, g)
  end subroutine cov_square_inv_mv_3Fac

  !> \brief multiplies a vector by the inverse of the square root of
  !!   the covariance matrix given as its EVD
  !! @param[in] U matrix whose columns are the leading eigenvalues
  !!   vector of the covariance matrix B, size (n, k)
  !! @param[in] D vector of leading eigenvalues, size k
  !! @param[in] f input vector of size n (size of the discretization grid)
  !! @param[out] g output vector of size n
  !! \details
  !! computes g = B^-0.5 f
  !<
  SUBROUTINE cov_square_inv_mv_default(U, D, f, g)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
    REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    REAL(cp), DIMENSION( SIZE(D) ) :: t

    !checking the input parameters
    CALL cov_square_mv_check(U, D, f, g, inv=.TRUE.)

    t = MATMUL(f, U)
    g = t/SQRT(D)
  END SUBROUTINE cov_square_inv_mv_default

  ! ***************************************************
  ! **************** debugging routines ***************
  ! ***************************************************

  !> \brief Check the conformity of the shape of matrices forming an EVD
  !! the program stops in case of non conformity
  !! @param [in] nU size of each singular vector
  !! @param [in] kU number singular vectors
  !! @param [in] kD1 number of singular values or on size of the diagonal matrix
  !! @param [in] kD2 optional (default 1) other size of the diagonal matrix
  !!   kD1 x kD2 is the shape of the diagonal matrix of singular values.
  !!   It can be stored as a full matrix or as a vector.
  !<
  SUBROUTINE EVD_check(nU, kU, kD1, kD2)
    INTEGER, INTENT(IN) :: nU, kU, kD1
    INTEGER, OPTIONAL, INTENT(IN) :: kD2
    !local variables
    INTEGER :: il_kD2

    IF( PRESENT(kD2)  )THEN
      il_kD2 = kD2
    ELSE
      il_kD2 = 1
    END IF

    IF( ( (kD1 == il_kD2).OR.( MIN(kD1, il_kD2) == 1 ) ) &
      .AND.( MAX(kD1, il_kD2) == kU ).AND.( nU >= kU ) )THEN
      !good configuration, nothing to do
    ELSE
      !bad configuration, message and stop the program
      CALL debug( 'Expecting EVD UDU^t to have the following specifications', tag=dALLWAYS )
      CALL debug( ' - U: number of rows greater or equal to the number of columns', tag=dALLWAYS )
      CALL debug( ' - D: vector or square matrix', tag=dALLWAYS )
      CALL debug( ' - MIN size of U equal to the MAX size of D', tag=dALLWAYS )
      CALL debug( 'For debuging purpose, here are the shapes of U and D', tag=dALLWAYS )
      CALL debug( (/nU, kU/), ' - SHAPE(U) = ', tag=dALLWAYS )
      CALL debug( (/kD1, il_kD2/), ' - SHAPE(D) = ', tag=dALLWAYS )
      CALL stop_program( 'Non consistant EVD' )
    END IF
  END SUBROUTINE EVD_check
!end of privates procedures
END MODULE evd_covariance


double precision function wf(k, l1x, l2x, l1y, l2y, l1abs, l2abs, cltt, clte, clee, lmaxtt, lmaxte, lmaxee)
    implicit None
    integer, intent(in) :: l1abs, l2abs, lmaxtt, lmaxte, lmaxee
    character(len=3), intent(in) :: k
    double precision, intent(in) :: l1x, l2x, l1y, l2y
    double precision, intent(in) :: cltt(lmaxtt), clte(lmaxte), clee(lmaxee)
    double precision cos2p, sin2p

    if (k == 'ptt') then
        wf =  (cltt(l1abs) * ((l1x + l2x) * l1x + (l1y + l2y) * l1y)  &
                + cltt(l2abs) * ((l1x + l2x) * l2x + (l1y + l2y) * l2y))

    else if (k == 'pte') then
        cos2p = 2d0 * (l1x * l2x + l1y * l2y) ** 2 / ( (l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y ** 2) ) - 1.
        wf = (clte(l1abs) * cos2p * ((l1x + l2x) * l1x + (l1y + l2y) * l1y)&
                +clte(l2abs) * ( (l1x + l2x) * l2x + (l1y + l2y) * l2y))

    else if (k == 'pet') then
        cos2p = 2d0 * (l2x * l1x + l2y * l1y) ** 2 / ( (l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y ** 2) ) - 1.
        wf = (clte(l2abs) * cos2p * ((l2x + l1x) * l2x + (l2y + l1y) * l2y)&
                + clte(l1abs) * ((l2x + l1x) * l1x + (l2y + l1y) * l1y))

    else if (k == 'ptb') then
        sin2p = 2d0 * (l1x * l2x + l1y * l2y) * (-l1y * l2x + l1x * l2y)/ ((l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y **2))
        wf = ((clte(l1abs) * ((l1x + l2x) * l1x + (l1y + l2y) * l1y)) * sin2p)

    else if (k == 'pbt') then
        sin2p = 2d0 * (l2x * l1x + l2y * l1y) * (-l2y * l1x + l2x * l1y)/ ((l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y **2))
        wf = ((clte(l2abs) * ((l2x + l1x) * l2x + (l2y + l1y) * l2y)) * sin2p)

    else if (k == 'pee') then
        cos2p = 2d0 * (l1x * l2x + l1y * l2y) ** 2 / ( (l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y ** 2) ) - 1.
        wf = (clee(l1abs) * ((l1x + l2x) * l1x + (l1y + l2y) * l1y) + &
                clee(l2abs) * ((l1x + l2x) * l2x + (l1y + l2y) * l2y)) * cos2p

    else if (k == 'peb') then
        !Note clBB absent here. If adding it, note Hu astro-ph/0111606 paper has the wrong sign in front of ClBB.
        sin2p = 2d0 * (l1x * l2x + l1y * l2y) * (-l1y * l2x + l1x * l2y)/ ((l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y **2))
        wf = (clee(l1abs) * ((l1x + l2x) * l1x + (l1y + l2y) * l1y)) * sin2p

    else if (k == 'pbe') then
        !Note clBB absent here. If adding it, note Hu astro-ph/0111606 paper has the wrong sign in front of ClBB.
        sin2p = 2d0 * (l2x * l1x + l2y * l1y) * (-l2y * l1x + l2x * l1y)/ ((l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y **2))
        wf = (clee(l2abs) * ((l2x + l1x) * l2x + (l2y + l1y) * l2y)) * sin2p

    else if ((k == 'pbb') .or. k =='xbb') then
        wf = 0d0

    else if (k == 'xtt') then
        wf =  (cltt(l1abs) * (-(l1y + l2y) * l1x + (l1x + l2x) * l1y) &
                + cltt(l2abs) * (-(l1y + l2y) * l2x + (l1x + l2x) * l2y))

    else if (k == 'xte') then
        cos2p = 2d0 * (l1x * l2x + l1y * l2y) ** 2 / ( (l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y ** 2) ) - 1.
        wf = (clte(l1abs) * cos2p * ( -(l1y + l2y) * l1x + (l1x + l2x) * l1y)&
                + clte(l2abs) * (-(l1y + l2y) * l2x + (l1x + l2x) * l2y))

    else if (k == 'xet') then
        cos2p = 2d0 * (l2x * l1x + l2y * l1y) ** 2 / ( (l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y ** 2) ) - 1.
        wf = (clte(l2abs) * cos2p * (-(l2y + l1y) * l2x + (l2x + l1x) * l2y) &
                + clte(l1abs) * (-(l2y + l1y) * l1x + (l2x + l1x) * l1y))

    else if (k == 'xtb') then
        sin2p = 2d0 * (l1x * l2x + l1y * l2y) * (-l1y * l2x + l1x * l2y)/ ((l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y **2))
        wf = (clte(l1abs) * (-(l1y + l2y) * l1x + (l1x + l2x) * l1y)) * sin2p

    else if (k == 'xbt') then
        sin2p = 2d0 * (l2x * l1x + l2y * l1y) * (-l2y * l1x + l2x * l1y)/ ((l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y **2))
        wf = (clte(l2abs) * (-(l2y + l1y) * l2x + (l2x + l1x) * l2y)) * sin2p

    else if (k == 'xee') then
        cos2p = 2d0 * (l1x * l2x + l1y * l2y) ** 2 / ( (l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y ** 2) ) - 1.
        wf = (clee(l1abs) * (-(l1y + l2y) * l1x + (l1x + l2x) * l1y) + clee(l2abs) * &
                (-(l1y + l2y) * l2x + (l1x + l2x) * l2y)) * cos2p

    else if (k == 'xeb') then
        !Note clBB absent here. If adding it, note Hu astro-ph/0111606 paper has the wrong sign in front of ClBB.
        sin2p = 2d0 * (l1x * l2x + l1y * l2y) * (-l1y * l2x + l1x * l2y)/ ((l1x ** 2 + l1y ** 2) * (l2x ** 2 + l2y **2))
        wf = (clee(l1abs) * (-(l1y + l2y) * l1x + (l1x + l2x) * l1y)) * sin2p

    else if (k == 'xbe') then
        !Note clBB absent here. If adding it, note Hu astro-ph/0111606 paper has the wrong sign in front of ClBB.
        sin2p = 2d0 * (l2x * l1x + l2y * l1y) * (-l2y * l1x + l2x * l1y)/ ((l2x ** 2 + l2y ** 2) * (l1x ** 2 + l1y **2))
        wf = (clee(l2abs) * (-(l2y + l1y) * l2x + (l2x + l1x) * l2y)) * sin2p

    else if (k == 'stt') then
        wf = 1d0

    else if (k == 'ftt') then
        wf = cltt(l1abs) + cltt(l2abs)

    else if ((k == 'ste') .or. (k == 'set') .or. (k == 'stb') .or. (k == 'stb') .or. (k == 'seb') .or. (k == 'sbe'))then
        wf = 0d0

    else
        wf = 0d0
        write(*,*) 'Failed to find QE weight function '//k
    end if
end

subroutine n1(ret, Ls, nL, cl_kI, kA, kB, kI, cltt, clte, clee, clttfid, cltefid, cleefid, &
                    ftlA, felA, fblA, ftlB, felB, fblB, lminA, lmaxA, lminB, lmaxB, lmaxI, &
                    lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid, dL, lps, nlps)
    implicit None
    integer, intent(in) :: Ls(nL), lmaxA, lmaxB, lmaxI, lminA, lminB, dL, nL
    integer, intent(in) :: lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid
    integer, intent(in) :: nlps, lps(0:nlps-1)
    double precision, intent(out) :: ret(nL)
    character(len=3), intent(in) :: kA, kB ! QE keys
    character(len=1), intent(in) :: kI     ! anisotropy source key
    double precision, intent(in) :: cltt(lmaxtt), clee(lmaxee), clte(lmaxte), cl_kI(lmaxI)
    double precision, intent(in) :: clttfid(lmaxttfid), cleefid(lmaxeefid), cltefid(lmaxtefid)
    double precision, intent(in) :: ftlA(lmaxA), felA(lmaxA), fblA(lmaxA)
    double precision, intent(in) :: ftlB(lmaxB), felB(lmaxB), fblB(lmaxB)
    double precision, external :: n1L
    integer iL

    !$OMP PARALLEL
    !$OMP DO SCHEDULE(DYNAMIC,1)
    do iL = 1, nL
        ret(iL) = n1L(Ls(iL), cl_kI, kA, kB, kI, cltt, clte, clee, clttfid, cltefid, cleefid, &
                    ftlA, felA, fblA, ftlB, felB, fblB, lminA, lmaxA, lminB, lmaxB, lmaxI, &
                    lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid, dL, lps, nlps)
    end do
    !$OMP ENDDO
    !$OMP END PARALLEL
end

double precision function n1L(L, cl_kI, kA, kB, kI, cltt, clte, clee, clttfid, cltefid, cleefid, &
                    ftlA, felA, fblA, ftlB, felB, fblB, lminA, lmaxA, lminB, lmaxB, lmaxI, &
                    lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid, dL, lps, nlps)
    implicit None
    integer, intent(in) :: L, lmaxA, lmaxB, lmaxI, lminA, lminB, dL
    integer, intent(in) :: lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid
    integer, intent(in) :: nlps, lps(0:nlps-1)
    ! lps is the anisotropy source multipole discretization.
    ! Planck 2018 used lps=(/1,2,12,22,32,42,52,62,72,82,92,102,132,162,192,222,252,282,312,342,372, &
    !    !                   402,432,462,492,522,552,652,752,852,952,1052,1152,1452,1752,2052,2352,2500/)
    character(len=3), intent(in) :: kA, kB ! QE keys
    character(len=1), intent(in) :: kI     ! anisotropy source key
    double precision, intent(in) :: cltt(lmaxtt), clee(lmaxee), clte(lmaxte), cl_kI(lmaxI)
    double precision, intent(in) :: clttfid(lmaxttfid), cleefid(lmaxeefid), cltefid(lmaxtefid)
    double precision, intent(in) :: ftlA(lmaxA), felA(lmaxA), fblA(lmaxA)
    double precision, intent(in) :: ftlB(lmaxB), felB(lmaxB), fblB(lmaxB)
    double precision, external :: wf ! QE weight functions

    double precision :: fal1(lmaxA), fal2(lmaxA), fal3(lmaxB), fal4(lmaxB)
    double precision ::  L1, L2, L3, L4, L1x, L1y, L2x, L2y, Lx, Ly, M_PI, L3x, L3y, L4x, L4y
    integer :: L1i, L2i, L3i, L4i, i
    double precision :: phi, dphi, dPh, PhiL_phi_dphi, fac, PhiLx, PhiLy, PhiL_phi, term1, term2
    integer :: nphi, phiIx, PhiLix, PhiLi, PhiL_nphi, PhiL_nphi_ix
    character(len=3) :: k13, k24, k14, k23
    double precision :: dlps(0:nlps-1)

    M_PI = 3.14159265358979323846d0
    Ly = 0d0
    Lx = float(L)

    k13 = kI // kA(2:2) // kB(2:2)
    k24 = kI // kA(3:3) // kB(3:3)
    k14 = kI // kA(2:2) // kB(3:3)
    k23 = kI // kA(3:3) // kB(2:2)

    dlps(0) = float(lps(1) - lps(0))
    do i = 1, nlps - 2
        dlps(i) = 0.5d0 * (lps(i + 1) - lps(i - 1))
    end do
    dlps(nlps - 1) = float(lps(nlps - 1) - lps(nlps - 2))

    if (kA(2:2) == 't') then
        fal1 = ftlA
    else if (kA(2:2) == 'e') then
        fal1 = felA
    else if (kA(2:2) == 'b') then
        fal1 = fblA
    else
        write(*,*) 'Failed to find cmb filter '//kA
    end if
    if (kB(2:2) == 't') then
        fal3 = ftlB
    else if (kB(2:2) == 'e') then
        fal3 = felB
    else if (kB(2:2) == 'b') then
        fal3 = fblB
    else
        write(*,*) 'Failed to find cmb filter '//kB
    end if
        if (kA(3:3) == 't') then
        fal2 = ftlA
    else if (kA(3:3) == 'e') then
        fal2 = felA
    else if (kA(3:3) == 'b') then
        fal2 = fblA
    else
        write(*,*) 'Failed to find cmb filter '//kA
    end if
    if (kB(3:3) == 't') then
        fal4= ftlB
    else if (kB(3:3) == 'e') then
        fal4 = felB
    else if (kB(3:3) == 'b') then
        fal4 = fblB
    else
        write(*,*) 'Failed to find cmb filter '//kB
    end if

    n1L = 0d0
    do L1i =  max(lminA, dL / 2), lmaxA, dL
        L1 = float(L1i)
        nphi = 2 * L1i + 1
        if (L1i > 3 * dL) then
            nphi = 2 * nint(0.5d0 * L1i  / float(dL)) + 1
        end if
        dphi = 2d0 * M_PI / nphi
        do phiIx = 0, (nphi - 1)/ 2
            phi = dphi * phiIx
            L1x = L1 * cos(phi)
            L1y = L1 * sin(phi)
            L2x = Lx - L1x
            L2y = Ly - L1y
            L2 = sqrt(L2x * L2x + L2y * L2y)
            if ( (L2 >= lminA) .AND. (L2 <= lmaxA) ) then
                L2i = nint(L2)
                !integral over (Lphi,Lphi_angle) according to lps grid.
                do PhiLix = 0, nlps - 1
                    PhiLi = lps(PhiLix)
                    dPh = dlps(PhiLix)
                    PhiL_nphi = 2 * PhiLi + 1
                    if (PhiLi > 20) then
                        PhiL_nphi = 2 * nint(0.5d0 * PhiL_nphi/dPh) + 1
                    end if
                    PhiL_phi_dphi = 2.d0 * M_PI / PhiL_nphi
                    fac  = (PhiL_phi_dphi * PhiLi * dPh) * (dphi * L1 * dL) / ( (2. * M_PI) ** 4. ) * 0.25d0
                    if (phiIx /= 0) then
                        fac = fac * 2d0
                    end if
                    fac = fac * wf(kA, L1x, L2x, L1y, L2y, L1i, L2i, clttfid, cltefid, cleefid, lmaxttfid, lmaxtefid, lmaxeefid)
                    fac = fac * fal1(L1i) * fal2(L2i)
                    do PhiL_nphi_ix = -(PhiL_nphi-1)/2, (PhiL_nphi-1)/2
                        PhiL_phi = PhiL_phi_dphi * PhiL_nphi_ix
                        PhiLx = PhiLi * cos(PhiL_phi)
                        PhiLy = PhiLi * sin(PhiL_phi)
                        L3x = PhiLx - L1x
                        L3y = PhiLy - L1y
                        L3 = sqrt(L3x*L3x + L3y*L3y)
                        if ((L3 >= lminB) .AND. (L3 <= lmaxB)) then
                            L3i = nint(L3)
                            L4x = -Lx - L3x
                            L4y = -Ly - L3y
                            L4 = sqrt(L4x * L4x + L4y * L4y)
                             if ((L4 >= lminB) .AND. (L4 <= lmaxB)) then
                                 L4i = nint(L4)
                                 ! wf(kA) and first two filters already absorded into 'fac'
                                 term1 = wf(kB, L3x, L4x, L3y, L4y, L3i, L4i, clttfid, cltefid, cleefid, &
                                                 lmaxttfid, lmaxtefid, lmaxeefid)&
                                         * wf(k13, L1x, L3x, L1y, L3y, L1i, L3i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * wf(k24, L2x, L4x, L2y, L4y, L2i, L4i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * fal3(L3i) * fal4(L4i)
                                 term2 = wf(kB, L4x, L3x, L4y, L3y, L4i, L3i, clttfid, cltefid, cleefid, &
                                           lmaxttfid, lmaxtefid, lmaxeefid)&
                                         * wf(k14, L1x, L3x, L1y, L3y, L1i, L3i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * wf(k23, L2x, L4x, L2y, L4y, L2i, L4i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * fal3(L4i) * fal4(L3i)
                                 n1L = n1L  + (term1 + term2) * fac * cl_kI(PhiLi)
                            end if
                        end if
                    end do
                end do
            end if
        end do
    end do
end

double precision function n1L_jtp(L, cl_kI, kA, kB, Xp, Yp, Ip, Jp, kI, cltt, clte, clee, clttfid, cltefid, cleefid, &
                    fXXp, fYYp, fIIp, fJJp, lminA, lmaxA, lminB, lmaxB, lmaxI, &
                    lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid, dL, lps, nlps)
    implicit None
    integer, intent(in) :: L, lmaxA, lmaxB, lmaxI, lminA, lminB, dL
    integer, intent(in) :: lmaxtt, lmaxte, lmaxee, lmaxttfid, lmaxtefid, lmaxeefid
    integer, intent(in) :: nlps, lps(0:nlps-1)
    ! lps is the anisotropy source multipole discretization.
    ! Planck 2018 used lps=(/1,2,12,22,32,42,52,62,72,82,92,102,132,162,192,222,252,282,312,342,372, &
    !    !                   402,432,462,492,522,552,652,752,852,952,1052,1152,1452,1752,2052,2352,2500/)
    character(len=3), intent(in) :: kA, kB ! QE keys (XY IJ), e.g. 'ptt' for lensing gradient TT estimator
    character(len=1), intent(in) :: kI, Xp, Yp, Ip, Jp     ! anisotropy source key (typically 'p' for lensing gradient, 'x' for curl) and response fields
    double precision, intent(in) :: cltt(lmaxtt), clee(lmaxee), clte(lmaxte), cl_kI(lmaxI)
    double precision, intent(in) :: clttfid(lmaxttfid), cleefid(lmaxeefid), cltefid(lmaxtefid)
    double precision, intent(in) :: fXXp(lmaxA), fYYp(lmaxA), fIIp(lmaxB), fJJp(lmaxB)

    double precision, external :: wf ! QE weight functions

    double precision :: fal1(lmaxA), fal2(lmaxA), fal3(lmaxB), fal4(lmaxB)
    double precision ::  L1, L2, L3, L4, L1x, L1y, L2x, L2y, Lx, Ly, M_PI, L3x, L3y, L4x, L4y
    integer :: L1i, L2i, L3i, L4i, i
    double precision :: phi, dphi, dPh, PhiL_phi_dphi, fac, PhiLx, PhiLy, PhiL_phi, term1, term2
    integer :: nphi, phiIx, PhiLix, PhiLi, PhiL_nphi, PhiL_nphi_ix
    character(len=3) :: k13, k24, k14, k23
    double precision :: dlps(0:nlps-1)

    M_PI = 3.14159265358979323846d0
    Ly = 0d0
    Lx = float(L)

    k13 = kI // Xp // Ip
    k24 = kI // Yp // Jp
    k14 = kI // Xp // Jp
    k23 = kI // Yp // Ip

    dlps(0) = float(lps(1) - lps(0))
    do i = 1, nlps - 2
        dlps(i) = 0.5d0 * (lps(i + 1) - lps(i - 1))
    end do
    dlps(nlps - 1) = float(lps(nlps - 1) - lps(nlps - 2))

    fal1 = fXXp
    fal2 = fYYp
    fal3 = fIIp
    fal4 = fJJp

    n1L_jtp = 0d0
    do L1i =  max(lminA, dL / 2), lmaxA, dL
        L1 = float(L1i)
        nphi = 2 * L1i + 1
        if (L1i > 3 * dL) then
            nphi = 2 * nint(0.5d0 * L1i  / float(dL)) + 1
        end if
        dphi = 2d0 * M_PI / nphi
        do phiIx = 0, (nphi - 1)/ 2
            phi = dphi * phiIx
            L1x = L1 * cos(phi)
            L1y = L1 * sin(phi)
            L2x = Lx - L1x
            L2y = Ly - L1y
            L2 = sqrt(L2x * L2x + L2y * L2y)
            if ( (L2 >= lminA) .AND. (L2 <= lmaxA) ) then
                L2i = nint(L2)
                !integral over (Lphi,Lphi_angle) according to lps grid.
                do PhiLix = 0, nlps - 1
                    PhiLi = lps(PhiLix)
                    dPh = dlps(PhiLix)
                    PhiL_nphi = 2 * PhiLi + 1
                    if (PhiLi > 20) then
                        PhiL_nphi = 2 * nint(0.5d0 * PhiL_nphi/dPh) + 1
                    end if
                    PhiL_phi_dphi = 2.d0 * M_PI / PhiL_nphi
                    fac  = (PhiL_phi_dphi * PhiLi * dPh) * (dphi * L1 * dL) / ( (2. * M_PI) ** 4. ) * 0.25d0
                    if (phiIx /= 0) then
                        fac = fac * 2d0
                    end if
                    do PhiL_nphi_ix = -(PhiL_nphi-1)/2, (PhiL_nphi-1)/2
                        PhiL_phi = PhiL_phi_dphi * PhiL_nphi_ix
                        PhiLx = PhiLi * cos(PhiL_phi)
                        PhiLy = PhiLi * sin(PhiL_phi)
                        L3x = PhiLx - L1x
                        L3y = PhiLy - L1y
                        L3 = sqrt(L3x*L3x + L3y*L3y)
                        if ((L3 >= lminB) .AND. (L3 <= lmaxB)) then
                            L3i = nint(L3)
                            L4x = -Lx - L3x
                            L4y = -Ly - L3y
                            L4 = sqrt(L4x * L4x + L4y * L4y)
                             if ((L4 >= lminB) .AND. (L4 <= lmaxB)) then
                                 L4i = nint(L4)
                                 term1 = wf(kA, L1x, L2x, L1y, L2y, L1i, L2i, clttfid, cltefid, cleefid, &
                                         lmaxttfid, lmaxtefid, lmaxeefid )&
                                         * wf(kB, L3x, L4x, L3y, L4y, L3i, L4i, clttfid, cltefid, cleefid, &
                                                 lmaxttfid, lmaxtefid, lmaxeefid)&
                                         * wf(k13, L1x, L3x, L1y, L3y, L1i, L3i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * wf(k24, L2x, L4x, L2y, L4y, L2i, L4i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * fal1(L1i) * fal2(L2i) * fal3(L3i) * fal4(L4i)
                                 term2 = wf(kA, L1x, L2x, L1y, L2y, L1i, L2i, clttfid, cltefid, cleefid, &
                                           lmaxttfid, lmaxtefid, lmaxeefid)&
                                         * wf(kB, L4x, L3x, L4y, L3y, L4i, L3i, clttfid, cltefid, cleefid, &
                                           lmaxttfid, lmaxtefid, lmaxeefid)&
                                         * wf(k14, L1x, L3x, L1y, L3y, L1i, L3i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * wf(k23, L2x, L4x, L2y, L4y, L2i, L4i, cltt, clte, clee, &
                                                 lmaxtt, lmaxte, lmaxee)&
                                         * fal1(L1i) * fal2(L2i) * fal3(L4i) * fal4(L3i)
                                 n1L_jtp = n1L_jtp  + (term1 + term2) * fac * cl_kI(PhiLi)
                            end if
                        end if
                    end do
                end do
            end if
        end do
    end do
end


!>
!! \brief This module contains physical constants and conversion factors
!!
!! Module for Capreole / C2-Ray (f90)
!!
!! \b Author: Garrelt Mellema
!!
!! \b Date:
!!
!! \b Version: cgs units
!!

module cgsconstants

  use precision, only: dp
  use mathconstants, only: pi

  implicit none

  ! A collection of physical constants and conversion factors
  ! Units: cgs

  !> proton mass
  real(kind=dp), parameter :: m_p=1.672661e-24_dp
  !> speed of light
  real(kind=dp), parameter :: c=2.997925e+10_dp
  !> Planck constant
  real(kind=dp), parameter :: hplanck=6.6260755e-27_dp
  !> Stefan-Boltzmann constant
  real(kind=dp), parameter :: sigmasb=5.670e-5_dp
  !> Boltzmann constant
  real(kind=dp), parameter :: kb=1.381e-16_dp
  !> Gravitational constant
  real(kind=dp), parameter :: G_grav=6.6732e-8_dp

  !> ev2k   - conversion factor between evs and kelvins
  real(kind=dp),parameter  :: ev2k=1.0/8.617e-05
  !> ev2erg  - conversion factor between evs and ergs
  real(kind=dp),parameter  :: ev2erg=1.602e-12
  !> ev2j   - conversion factor between ergs and Joules
  real(kind=dp),parameter  :: erg2j=1e-7

  ! The following are scaled to frequency scaling

  !> Frequency scaling factor,
  !! this scaling parameter is independent of any main program scaling
  !! (see scaling.f90), and may only be used in the radiation physics
  !! subroutines (currently switched off)
  real(kind=dp),parameter  :: sclfre=1.0e15
  !> conversion between evs and frequency
  real(kind=dp),parameter  :: ev2fr=0.241838e15!/sclfre

  ! h/k, Planck/Boltzm
  ! Check this number, seems scaled
  !real(kind=dp),parameter  :: hoverk=47979.72484
  !> Planck constant scaled
  real(kind=dp),parameter  :: hscl=hplanck!*sclfre
  !> tpic2  - 2*pi/c^2 times scaling factors needed for the integral cores
  real(kind=dp),parameter :: tpic2=2.0*pi/(c*c)
  !> two_pi_c2  - 2*pi/c^2 times scaling factors needed for the integral cores
  real(kind=dp),parameter :: two_pi_c2=2.0*pi/(c*c)!*sclfre**3

  !> Hydrogen recombination parameter (power law index)
  real(kind=dp),parameter :: albpow=-0.7_dp  !in the old code -0.79
  !> Hydrogen recombination parameter (value at 10^4 K)
  real(kind=dp),parameter :: bh00=2.59e-13_dp ! OTS value, alpha_B
  !> Helium0 recombination parameter (power law index)
  real(kind=dp), parameter :: alcpow=-0.672_dp
  !> Helium0 recombination parameter (value at 10^4 K)
  real(kind=dp), parameter :: bhe00=4.26e-13_dp !alpha_b+alpha_1
  !> Helium1 recombination parameter (value at 10^4 K)
  real(kind=dp), parameter :: bhe10=1.53e-12_dp !different in the book!
  !here it was 5.91e-12 I replace with book value of 2*1.1e-12

  !> Hydrogen ionization energy (in eV)
  real(kind=dp), parameter :: eth0=13.598
  !> Hydrogen ionization energy (in erg)
  real(kind=dp),parameter :: hionen=eth0*ev2erg
  !> Hydrogen ionization energy expressed in K
  real(kind=dp),parameter :: temph0=eth0*ev2k
  !> Hydrogen collisional ionization parameter 1
  real(kind=dp),parameter :: xih0=1.0
  !> Hydrogen collisional ionization parameter 2
  real(kind=dp),parameter :: fh0=0.83
  !> Hydrogen collisional ionization parameter
  real(kind=dp),parameter :: colh0=1.3e-8*fh0*xih0/(eth0*eth0)

  !> Helium ionization energy (in eV)
  real(kind=dp), dimension(0:1), parameter :: ethe=(/24.587,54.416/)
  !> Helium ionization energy (in erg)
  real(kind=dp), dimension(0:1), parameter :: heionen=(/ethe(0)*ev2erg,ethe(1)*ev2erg/)
  !> Helium ionization energy expressed in K
  real(kind=dp), dimension(0:1), parameter :: temphe=(/ethe(0)*ev2k,ethe(1)*ev2k/)
  !> Helium collisional ionization parameter 1
  real(kind=dp),dimension(0:1),parameter :: xihe=(/2.0,1.0/)
  !> Helium collisional ionization parameter 2
  real(kind=dp),dimension(0:1),parameter :: fhe=(/0.63,1.30/)
  !> Helium collisional ionization parameter
  real(kind=dp),dimension(0:1),parameter :: colhe=(/1.3e-8*fhe(0)*xihe(0)/(ethe(0)*ethe(0)), &
  	1.3e-8*fhe(1)*xihe(1)/(ethe(1)*ethe(1))/)

end module cgsconstants


c do continuum subtraction by subtracting a low order Legendre polynomial
c fit to the good data points.
c I added a sigma-clipping routine before the fit, which may not
c work great since the continuum varies, avsigclip or something
c would be better.

c do the subtraction in place, or not
      subroutine contsubleg(wave,spec,serr,nsp,iord)

c      parameter (IORDER=15)

      real wave(nsp),spec(nsp),serr(nsp)
      real wscale(nsp),specclip(nsp)
      real wfit(nsp),ffit(nsp),efit(nsp)
      real a(iord),uu(nsp,iord),vv(iord,iord),ww(iord)
      real avals(iord)

      external fleg

      include 'pcredshift.h'

      ncliprad=100
      clipsig=2.0
      call localsigclip(nsp,spec,specclip,ncliprad,clipsig)

      wrange = wave(nsp) - wave(1)
      do i=1,nsp
c rescale wfit to run between 0 and 1 for improved polynomial fitting
         wscale(i) = (wave(i) - wave(1)) / wrange
      end do

      npoly=iord
      nfit=0
      do i=1,nsp
         if(specclip(i) .gt. bad .and. serr(i) .gt. bad
     $        .and. serr(i) .lt. 1.0e6) then
            nfit=nfit+1
            wfit(nfit)=wscale(i)
            ffit(nfit)=specclip(i)
            efit(nfit)=serr(i)
         end if
      end do
      if (nfit .le. npoly) return

c do fit
      call bigsvdfit(wfit,ffit,efit,nfit,a,npoly,uu,vv,ww,nsp,iord,
     $     chisq,fleg)

c evaluate and subtract fit
      do i=1,nsp
c         call fleg(wave(i),avals,npoly)
         call fleg(wscale(i),avals,npoly)
         fitval = 0.
         do j=1,npoly
            fitval = fitval + a(j)*avals(j)
         end do
         if (spec(i) .gt. bad) then
            spec(i) = spec(i) - fitval
         end if
      end do

      return
      end

cccccccccccccccccccccccccccccc
c from Numerical Recipes, generates Legendre polynomials
c via recurrence relation

      SUBROUTINE fleg(x,pl,nl)
      INTEGER nl
      REAL x,pl(nl)
      INTEGER j
      REAL d,f1,f2,twox
      pl(1)=1.
      pl(2)=x
      if(nl.gt.2) then
        twox=2.*x
        f2=x
        d=1.
        do 11 j=3,nl
          f1=d
          f2=f2+twox
          d=d+1.
          pl(j)=(f2*pl(j-1)-f1*pl(j-2))/d
11      continue
      endif
      return
      END


       program gen_gl

*************************************************************************
*** Written by Lin-Wang Wang, 2001
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

       implicit double precision(a-h,o-z)
       real*8 y(1000),aj(1000,0:7),daj(1000,0:7)
       real*8 yz(2,0:7)
       real*8 gl(1001,0:7)
       real*8 aj_t1(0:7),aj_t2(0:7)
       real*8 y_cut(0:7),aj_cut(0:7)

       do i=1,1000
       y(i)=(i-1)*20.d0/1000
       if(i.eq.1) y(i)=1.D-3
       x=y(i)
       aj(i,0)=dsin(x)/x
       aj(i,1)=dsin(x)/x**2-dcos(x)/x
       do j=1,6
       aj(i,j+1)=(2*j+1)*aj(i,j)/x-aj(i,j-1)
       enddo
       enddo
ccccccc deal with the numerical error problem
ccccccc we didn't use Taylor expansion
       y(1)=0.d0
       aj(1,0)=1.d0
       do j=1,7
       aj(1,j)=0.d0
       enddo

       do j=1,7
       aj_min=100.d0
       do i=2,300
       if(y(i).lt.0.5d0) then
       if(aj(i,j).gt.0.d0.and.aj(i,j).lt.aj_min) then
       aj_min=aj(i,j)
       i_min=i
       endif
       endif
       enddo
       y_cut(j)=y(i_min)
       aj_cut(j)=aj_min
       do i=2,i_min
       aj(i,j)=aj_cut(j)*(y(i)/y_cut(j))**j
       if(aj(i,j).lt.1.D-30) aj(i,j)=0.d0
       enddo
       enddo
ccccccccccccccccccccccccccccccccccccccccccc

       do i=1,1000
       daj(i,0)=-aj(i,1)
       do j=1,6
       daj(i,j)=(j*aj(i,j-1)-(j+1)*aj(i,j+1))/(2*j+1)
       enddo
       enddo

       do j=0,6
       ll=0
       do i=6,1000
       if(daj(i-1,j)*daj(i,j).lt.0.d0) then
       x=(daj(i,j)*y(i-1)-daj(i-1,j)*y(i))/
     &       (daj(i,j)-daj(i-1,j))
       if(ll.le.1) then
       ll=ll+1
       yz(ll,j)=x
       endif
       endif
       enddo
       enddo

       yz(2,0)=yz(1,0)
       yz(1,0)=0.d0

c       do j=0,6
c       write(6,*) j, yz(1,j),yz(2,j)
c       enddo
ccccccccccccccccccccccccccccccccccccccccccccccccccc
       do j=0,6

       call get_aj(aj_t2,yz(2,j),aj_cut,y_cut)
       call get_aj(aj_t1,yz(1,j),aj_cut,y_cut)

       fac=aj_t2(j)/aj_t1(j)

       do i=1,1001
       x=(i-1)*1.d0/1000
       x1=x*yz(1,j)
       x2=x*yz(2,j)

       call get_aj(aj_t1,x1,aj_cut,y_cut)
       call get_aj(aj_t2,x2,aj_cut,y_cut)
       gl(i,j)=aj_t2(j)-aj_t1(j)*fac

ccccccccc  there is one minors for very small x and gl(i,5)
       gl(i,j)=dabs(gl(i,j))

       enddo

       enddo

ccccccccccccccccccccccccccccccccccccccccccc
       do j=0,6
       sum=0.d0
       do i=1,1001
       x=(i-1)*1.d0/1000
       sum=sum+gl(i,j)*x**(j+2)
       enddo
       sum=sum*1.d0/1000
       sum=1.d0/sum
       do i=1,1001
       gl(i,j)=sum*gl(i,j)
       enddo
       enddo
ccccccccccccccccccccccccccccccccccccccccccc

       open(10,file="graph.j")
       rewind(10)
       do i=1,1001
       x=(i-1)*1.d0/1000
       write(10,200) x,(gl(i,j),j=0,6)
       enddo
       close(10)
200    format(9(E13.7,1x))

       stop
       end

       subroutine get_aj(aj_t,x1,aj_cut,y_cut)
       implicit double precision (a-h,o-z)
       real*8 x, aj_t(0:6), aj_cut(0:6), y_cut(0:6)

       x=x1
       if(x.lt.1.D-5) x=1.D-5

       aj_t(0)=dsin(x)/x
       aj_t(1)=dsin(x)/x**2-dcos(x)/x
       do j=1,6
       aj_t(j+1)=(2*j+1)*aj_t(j)/x-aj_t(j-1)
       enddo

       do j=1,6
       if(x.lt.y_cut(j)) then
       aj_t(j)=aj_cut(j)*(x1/y_cut(j))**j
       if(aj_t(j).lt.1.D-30) aj_t(j)=0.d0
       endif
       enddo

       if(x1.lt.1.D-5) aj_t(0)=1.d0

       return
       end


      SUBROUTINE POLINT4F (XA,YA,X,Y)

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C  The POLINT4 routine is based on the POLINT routine from "Numerical Recipes",
C  but assuming N=4, and ignoring the error estimation.
C  suggested by Z. Sullivan.
      DIMENSION XA(*),YA(*)

      H1=XA(1)-X
      H2=XA(2)-X
      H3=XA(3)-X
      H4=XA(4)-X

      W=YA(2)-YA(1)
      DEN=W/(H1-H2)
      D1=H2*DEN
      C1=H1*DEN

      W=YA(3)-YA(2)
      DEN=W/(H2-H3)
      D2=H3*DEN
      C2=H2*DEN

      W=YA(4)-YA(3)
      DEN=W/(H3-H4)
      D3=H4*DEN
      C3=H3*DEN

      W=C2-D1
      DEN=W/(H1-H3)
      CD1=H3*DEN
      CC1=H1*DEN

      W=C3-D2
      DEN=W/(H2-H4)
      CD2=H4*DEN
      CC2=H2*DEN

      W=CC2-CD1
      DEN=W/(H1-H4)
      DD1=H4*DEN
      DC1=H1*DEN

      If((H3+H4).lt.0D0) Then
         Y=YA(4)+D3+CD2+DD1
      Elseif((H2+H3).lt.0D0) Then
         Y=YA(3)+D2+CD1+DC1
      Elseif((H1+H2).lt.0D0) Then
         Y=YA(2)+C2+CD1+DC1
      ELSE
         Y=YA(1)+C1+CC1+DC1
      ENDIF

      RETURN
C               *************************
      END


c     # This routine computes the flux of cell-centered
c     #
c     # All scaling and potential sign changes are handled by the
c     # calling routine.
c

      subroutine  rpn2_cons_update(meqn,maux, idir, iface, q,
     &                             auxvec_center,
     &                             auxvec_edge,flux)
      implicit none

      integer meqn,maux,idir, iface
      double precision q(meqn), flux(meqn)
      double precision auxvec_center(maux), auxvec_edge(maux)

      double precision grav
      common /cparam/  grav

      double precision hun, hut, h, un, ut

      integer mu, mv

c     #  f1 = (hu; hu^2 + 0.5*g*h^2; huv)
c     #  f2 = (hv; huv; hv^2 + 0.5*gh^2)

      if (idir .eq. 0) then
          mu = 2
          mv = 3
      else
          mu = 3
          mv = 2
      endif

      hun = q(mu)
      hut = q(mv)

      h = q(1)
      un = hun/h
      ut = hut/h

      flux(1) = hun
      flux(mu) = hun**2/h + 0.5*grav*h**2
      flux(mv) = un*hut
c      flux(4) = un*q(4)

      end