!******************************************************************************
!*
!*                             BASIC STATISTICS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 08/2007.
  !    - 09/2013: add autocorrel.
  !    - 08/2014: transfer Rmat2corr.
  !    - 05/2015: transfer corr2Rmat.
  !    - 03/2016: add MASK for SIGMA and MEDIAN.
  !    - 07/2016: add the computation of the integrated autocorrelation time
  !               and of the effective sample size of an MCMC.
  !
  ! 3) DESCRIPTION: computes the basic statistical quantities for a given
  !                 data set.
  !==========================================================================

MODULE statistics

  USE utilities, ONLY:
  USE arrays, ONLY:
  USE special_functions, ONLY:
  USE FFT_specials, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: moment_data, median_data, median, median_conf, info_data, fwhm_data
  PUBLIC :: mean, sigma, Rmat2corr, corr2Rmat, Vmat2corr, N_corr, correlate
  PUBLIC :: autocorrel, correl_parlist, correl_index, intautocorrtime

  INTERFACE mean
    MODULE PROCEDURE mean_1D, mean_2D, mean_3D, mean_4D
    MODULE PROCEDURE mean_4D_dim, mean_3D_dim, mean_2D_dim
  END INTERFACE mean

  INTERFACE median ! alias
    MODULE PROCEDURE median_data_1D, median_data_2D, median_data_3D
    MODULE PROCEDURE median_data_4D
    MODULE PROCEDURE median_data_2D_dim, median_data_3D_dim, median_data_4D_dim
    MODULE PROCEDURE median_data_wei
  END INTERFACE median

  INTERFACE median_data
    MODULE PROCEDURE median_data_1D, median_data_2D, median_data_3D
    MODULE PROCEDURE median_data_4D
    MODULE PROCEDURE median_data_2D_dim, median_data_3D_dim, median_data_4D_dim
    MODULE PROCEDURE median_data_wei
  END INTERFACE median_data

  INTERFACE median_conf
    MODULE PROCEDURE median_conf_1D, median_conf_2D, median_conf_3D
    MODULE PROCEDURE median_conf_4D
  END INTERFACE median_conf

  INTERFACE sigma
    MODULE PROCEDURE sigma_1D, sigma_2D, sigma_3D, sigma_4D
    MODULE PROCEDURE sigma_2D_dim, sigma_3D_dim, sigma_4D_dim
  END INTERFACE sigma

  INTERFACE correlate
    MODULE PROCEDURE correlate_1D, correlate_2D, correlate_3D, correlate_4D
  END INTERFACE correlate

  INTERFACE info_data
    MODULE PROCEDURE info_data_1D, info_data_2D
  END INTERFACE info_data

  INTERFACE Rmat2corr
    MODULE PROCEDURE Rmat2corr_DP, Rmat2corr_log, Rmat2corr_char
  END INTERFACE Rmat2corr

  INTERFACE corr2Rmat
    MODULE PROCEDURE corr2Rmat_DP
  END INTERFACE corr2Rmat

  INTERFACE correl_parlist
    MODULE PROCEDURE correl_parlist_DP, correl_parlist_char
  END INTERFACE correl_parlist

  LOGICAL, PARAMETER :: upper = .True.

CONTAINS

  !==========================================================================
  ! m(X) = MEAN(X[],weight[],mask[],dim)
  !
  !   Computes the mean of the variable X, with weights w. If w is not
  ! supplied then the distribution is assumed to be uniform.
  !==========================================================================

  PURE FUNCTION mean_4D (x,weight,mask)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: mean_4D

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

    IF (PRESENT(weight)) THEN
      IF (PRESENT(mask)) THEN
        mean_4D = SUM(x(:,:,:,:)*weight(:,:,:,:),MASK=mask(:,:,:,:)) &
                / SUM(weight(:,:,:,:),MASK=mask(:,:,:,:))
      ELSE
        mean_4D = SUM(x(:,:,:,:)*weight(:,:,:,:)) / SUM(weight(:,:,:,:))
      END IF
    ELSE
      IF (PRESENT(mask)) THEN
        mean_4D = SUM(x(:,:,:,:),MASK=mask(:,:,:,:)) / COUNT(mask(:,:,:,:))
      ELSE
        mean_4D = SUM(x(:,:,:,:)) / SIZE(x(:,:,:,:))
      END IF
    END IF

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

  END FUNCTION mean_4D

  ! Shell Interfaces
  !-----------------
  ! 3D
  PURE FUNCTION mean_3D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: mean_3D
    INTEGER, DIMENSION(4) :: N
    N = [SIZE(x,1),SIZE(x,2),SIZE(x,3),1]
    IF (.NOT. PRESENT(weight)) THEN
      IF (.NOT. PRESENT(mask)) THEN
        mean_3D = MEAN_4D(RESHAPE(x(:,:,:),N(:)))
      ELSE
        mean_3D = MEAN_4D(RESHAPE(x(:,:,:),N(:)),MASK=RESHAPE(mask(:,:,:),N(:)))
      END IF
    ELSE
      IF (.NOT. PRESENT(mask)) THEN
        mean_3D = MEAN_4D(RESHAPE(x(:,:,:),N(:)), &
                          WEIGHT=RESHAPE(weight(:,:,:),N(:)))
      ELSE
        mean_3D = MEAN_4D(RESHAPE(x(:,:,:),N(:)), &
                          WEIGHT=RESHAPE(weight(:,:,:),N(:)), &
                          MASK=RESHAPE(mask(:,:,:),N(:)))
      END IF
    END IF
  END FUNCTION mean_3D

  ! 2D
  PURE FUNCTION mean_2D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: mean_2D
    INTEGER, DIMENSION(4) :: N
    N = [SIZE(x,1),SIZE(x,2),1,1]
    IF (.NOT. PRESENT(weight)) THEN
      IF (.NOT. PRESENT(mask)) THEN
        mean_2D = MEAN_4D(RESHAPE(x(:,:),N(:)))
      ELSE
        mean_2D = MEAN_4D(RESHAPE(x(:,:),N(:)),MASK=RESHAPE(mask(:,:),N(:)))
      END IF
    ELSE
      IF (.NOT. PRESENT(mask)) THEN
        mean_2D = MEAN_4D(RESHAPE(x(:,:),N(:)),WEIGHT=RESHAPE(weight(:,:),N(:)))
      ELSE
        mean_2D = MEAN_4D(RESHAPE(x(:,:),N(:)), &
                          WEIGHT=RESHAPE(weight(:,:),N(:)), &
                          MASK=RESHAPE(mask(:,:),N(:)))
      END IF
    END IF
  END FUNCTION mean_2D

  ! 1D
  PURE FUNCTION mean_1D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1)), INTENT(IN), OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: mean_1D
    INTEGER, DIMENSION(4) :: N
    N = [SIZE(x,1),1,1,1]
    IF (.NOT. PRESENT(weight)) THEN
      IF (.NOT. PRESENT(mask)) THEN
        mean_1D = MEAN_4D(RESHAPE(x(:),N(:)))
      ELSE
        mean_1D = MEAN_4D(RESHAPE(x(:),N(:)),MASK=RESHAPE(mask(:),N(:)))
      END IF
    ELSE
      IF (.NOT. PRESENT(mask)) THEN
        mean_1D = MEAN_4D(RESHAPE(x(:),N(:)),WEIGHT=RESHAPE(weight(:),N(:)))
      ELSE
        mean_1D = MEAN_4D(RESHAPE(x(:),N(:)),WEIGHT=RESHAPE(weight(:),N(:)), &
                          MASK=RESHAPE(mask(:),N(:)))
      END IF
    END IF
  END FUNCTION mean_1D

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

  PURE FUNCTION mean_4D_dim (x,weight,mask,dim)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: mask
    INTEGER, INTENT(IN) :: dim
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(3,2,dim == 1 .OR. dim == 2)), &
                        SIZE(x,MERGE(3,4,dim == 4))) :: mean_4D_dim

    INTEGER :: i1, i2, i3, i4, N1, N2, N3, N4

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

    N1 = SIZE(x(:,:,:,:),1)
    N2 = SIZE(x(:,:,:,:),2)
    N3 = SIZE(x(:,:,:,:),3)
    N4 = SIZE(x(:,:,:,:),4)
    SELECT CASE (dim)

      CASE (1)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i2,i3,i4) = MEAN_1D(x(:,i2,i3,i4))
          ELSE
            FORALL (i2=1:N2,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i2,i3,i4) = MEAN_1D(x(:,i2,i3,i4), &
                                              MASK=mask(:,i2,i3,i4))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i2,i3,i4) = MEAN_1D(x(:,i2,i3,i4), &
                                              WEIGHT=weight(:,i2,i3,i4))
          ELSE
            FORALL (i2=1:N2,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i2,i3,i4) = MEAN_1D(x(:,i2,i3,i4), &
                                              MASK=mask(:,i2,i3,i4), &
                                              WEIGHT=weight(:,i2,i3,i4))
          END IF
        END IF

      CASE (2)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i1,i3,i4) = MEAN_1D(x(i1,:,i3,i4))
          ELSE
            FORALL (i1=1:N1,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i1,i3,i4) = MEAN_1D(x(i1,:,i3,i4), &
                                              MASK=mask(i1,:,i3,i4))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i1,i3,i4) = MEAN_1D(x(i1,:,i3,i4), &
                                              WEIGHT=weight(i1,:,i3,i4))
          ELSE
            FORALL (i1=1:N1,i3=1:N3,i4=1:N4) &
              mean_4D_dim(i1,i3,i4) = MEAN_1D(x(i1,:,i3,i4), &
                                              MASK=mask(i1,:,i3,i4), &
                                              WEIGHT=weight(i1,:,i3,i4))
          END IF
        END IF

      CASE (3)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2,i4=1:N4) &
              mean_4D_dim(i1,i2,i4) = MEAN_1D(x(i1,i2,:,i4))
          ELSE
            FORALL (i1=1:N1,i2=1:N2,i4=1:N4) &
              mean_4D_dim(i1,i2,i4) = MEAN_1D(x(i1,i2,:,i4), &
                                              MASK=mask(i1,i2,:,i4))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2,i4=1:N4) &
              mean_4D_dim(i1,i2,i4) = MEAN_1D(x(i1,i2,:,i4), &
                                              WEIGHT=weight(i1,i2,:,i4))
          ELSE
            FORALL (i1=1:N1,i2=1:N2,i4=1:N4) &
              mean_4D_dim(i1,i2,i4) = MEAN_1D(x(i1,i2,:,i4), &
                                              MASK=mask(i1,i2,:,i4), &
                                              WEIGHT=weight(i1,i2,:,i4))
          END IF
        END IF

      CASE (4)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2,i3=1:N3) &
              mean_4D_dim(i1,i2,i3) = MEAN_1D(x(i1,i2,i3,:))
          ELSE
            FORALL (i1=1:N1,i2=1:N2,i3=1:N3) &
              mean_4D_dim(i1,i2,i3) = MEAN_1D(x(i1,i2,i3,:), &
                                              MASK=mask(i1,i2,i3,:))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2,i3=1:N3) &
              mean_4D_dim(i1,i2,i3) = MEAN_1D(x(i1,i2,i3,:), &
                                              WEIGHT=weight(i1,i2,i3,:))
          ELSE
            FORALL (i1=1:N1,i2=1:N2,i3=1:N3) &
              mean_4D_dim(i1,i2,i3) = MEAN_1D(x(i1,i2,i3,:), &
                                              MASK=mask(i1,i2,i3,:), &
                                              WEIGHT=weight(i1,i2,i3,:))
          END IF
        END IF

    END SELECT

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

  END FUNCTION mean_4D_dim

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

  PURE FUNCTION mean_3D_dim (x,weight,mask,dim)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    INTEGER, INTENT(IN) :: dim
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(2,3,dim == 3))) :: mean_3D_dim

    INTEGER :: i1, i2, i3, N1, N2, N3

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

    N1 = SIZE(x(:,:,:),1)
    N2 = SIZE(x(:,:,:),2)
    N3 = SIZE(x(:,:,:),3)
    SELECT CASE (dim)

      CASE (1)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2,i3=1:N3) &
              mean_3D_dim(i2,i3) = MEAN_1D(x(:,i2,i3))
          ELSE
            FORALL (i2=1:N2,i3=1:N3) &
              mean_3D_dim(i2,i3) = MEAN_1D(x(:,i2,i3),MASK=mask(:,i2,i3))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2,i3=1:N3) &
              mean_3D_dim(i2,i3) = MEAN_1D(x(:,i2,i3),WEIGHT=weight(:,i2,i3))
          ELSE
            FORALL (i2=1:N2,i3=1:N3) &
              mean_3D_dim(i2,i3) = MEAN_1D(x(:,i2,i3),MASK=mask(:,i2,i3), &
                                           WEIGHT=weight(:,i2,i3))
          END IF
        END IF

      CASE (2)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i3=1:N3) &
              mean_3D_dim(i1,i3) = MEAN_1D(x(i1,:,i3))
          ELSE
            FORALL (i1=1:N1,i3=1:N3) &
              mean_3D_dim(i1,i3) = MEAN_1D(x(i1,:,i3),MASK=mask(i1,:,i3))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i3=1:N3) &
              mean_3D_dim(i1,i3) = MEAN_1D(x(i1,:,i3),WEIGHT=weight(i1,:,i3))
          ELSE
            FORALL (i1=1:N1,i3=1:N3) &
              mean_3D_dim(i1,i3) = MEAN_1D(x(i1,:,i3),MASK=mask(i1,:,i3), &
                                           WEIGHT=weight(i1,:,i3))
          END IF
        END IF

      CASE (3)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2) &
              mean_3D_dim(i1,i2) = MEAN_1D(x(i1,i2,:))
          ELSE
            FORALL (i1=1:N1,i2=1:N2) &
              mean_3D_dim(i1,i2) = MEAN_1D(x(i1,i2,:),MASK=mask(i1,i2,:))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1,i2=1:N2) &
              mean_3D_dim(i1,i2) = MEAN_1D(x(i1,i2,:),WEIGHT=weight(i1,i2,:))
          ELSE
            FORALL (i1=1:N1,i2=1:N2) &
              mean_3D_dim(i1,i2) = MEAN_1D(x(i1,i2,:),MASK=mask(i1,i2,:), &
                                           WEIGHT=weight(i1,i2,:))
          END IF
        END IF

    END SELECT

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

  END FUNCTION mean_3D_dim

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

  PURE FUNCTION mean_2D_dim (x,weight,mask,dim)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    INTEGER, INTENT(IN) :: dim
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1))) :: mean_2D_dim

    INTEGER :: i1, i2, N1, N2

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

    N1 = SIZE(x(:,:),1)
    N2 = SIZE(x(:,:),2)
    SELECT CASE (dim)

      CASE (1)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2) mean_2D_dim(i2) = MEAN_1D(x(:,i2))
          ELSE
            FORALL (i2=1:N2) &
              mean_2D_dim(i2) = MEAN_1D(x(:,i2),MASK=mask(:,i2))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i2=1:N2) &
              mean_2D_dim(i2) = MEAN_1D(x(:,i2),WEIGHT=weight(:,i2))
          ELSE
            FORALL (i2=1:N2) &
              mean_2D_dim(i2) = MEAN_1D(x(:,i2),MASK=mask(:,i2), &
                                        WEIGHT=weight(:,i2))
          END IF
        END IF

      CASE (2)
        IF (.NOT. PRESENT(weight)) THEN
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1) mean_2D_dim(i1) = MEAN_1D(x(i1,:))
          ELSE
            FORALL (i1=1:N1) &
              mean_2D_dim(i1) = MEAN_1D(x(i1,:),MASK=mask(i1,:))
          END IF
        ELSE
          IF (.NOT. PRESENT(mask)) THEN
            FORALL (i1=1:N1) &
              mean_2D_dim(i1) = MEAN_1D(x(i1,:),WEIGHT=weight(i1,:))
          ELSE
            FORALL (i1=1:N1) &
              mean_2D_dim(i1) = MEAN_1D(x(i1,:),MASK=mask(i1,:), &
                                        WEIGHT=weight(i1,:))
          END IF
        END IF

    END SELECT

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

  END FUNCTION mean_2D_dim

  !==========================================================================
  ! s(X) = SIGMA(X,dim,mask)
  !        SIGMA(X[N],weight[N])
  !
  !   Computes the standard deviation of the variable X, with weights w. If w
  ! is not supplied then the distribution is assumed to be uniform.
  !==========================================================================

  PURE FUNCTION sigma_4D (x,weight,mask)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: sigma_4D

    INTEGER :: N
    REAL(DP) :: norm, av
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)) :: mask4D

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

    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,:) = mask(:,:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    N = COUNT(mask4D(:,:,:,:))
    IF (.NOT. PRESENT(weight)) THEN
      av = SUM(x(:,:,:,:),MASK=mask4D(:,:,:,:)) / N
      sigma_4D = SQRT( SUM((x(:,:,:,:)-av)**2,MASK=mask4D(:,:,:,:))/(N-1._DP) )
    ELSE
      norm = SUM(weight(:,:,:,:),MASK=mask4D(:,:,:,:))
      av = SUM(x(:,:,:,:)*weight(:,:,:,:),MASK=mask4D(:,:,:,:)) / norm
      sigma_4D = SQRT( SUM((x(:,:,:,:)-av)**2*weight(:,:,:,:), &
                           MASK=mask4D(:,:,:,:)) &
                     / norm * N/(N-1._DP) )
    END IF

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

  END FUNCTION sigma_4D

  ! Interface shells
  !-----------------
  ! 3D
  PURE FUNCTION sigma_3D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: sigma_3D
    INTEGER, DIMENSION(4) :: N
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),1) :: mask4D
    N = [SIZE(x,1),SIZE(x,2),SIZE(x,3),1]
    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,1) = mask(:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    IF (.NOT. PRESENT(weight)) THEN
      sigma_3D = SIGMA_4D(RESHAPE(x(:,:,:),N(:)),MASK=mask4D(:,:,:,:))
    ELSE
      sigma_3D = SIGMA_4D(RESHAPE(x(:,:,:),N(:)), &
                          WEIGHT=RESHAPE(weight(:,:,:),N(:)), &
                          MASK=mask4D(:,:,:,:))
    END IF
  END FUNCTION sigma_3D

  ! 2D
  PURE FUNCTION sigma_2D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: sigma_2D
    INTEGER, DIMENSION(4) :: N
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),1,1) :: mask4D
    N = [SIZE(x,1),SIZE(x,2),1,1]
    IF (PRESENT(mask)) THEN ; mask4D(:,:,1,1) = mask(:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    IF (.NOT. PRESENT(weight)) THEN
      sigma_2D = SIGMA_4D(RESHAPE(x(:,:),N(:)),MASK=mask4D(:,:,:,:))
    ELSE
      sigma_2D = SIGMA_4D(RESHAPE(x(:,:),N(:)), &
                          WEIGHT=RESHAPE(weight(:,:),N(:)),MASK=mask4D(:,:,:,:))
    END IF
  END FUNCTION sigma_2D

  ! 1D
  PURE FUNCTION sigma_1D (x,weight,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: x
    REAL(DP), DIMENSION(SIZE(x,1)), INTENT(IN), OPTIONAL :: weight
    LOGICAL, DIMENSION(SIZE(x,1)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: sigma_1D
    INTEGER, DIMENSION(4) :: N
    LOGICAL, DIMENSION(SIZE(x,1),1,1,1) :: mask4D
    N = [SIZE(x,1),1,1,1]
    IF (PRESENT(mask)) THEN ; mask4D(:,1,1,1) = mask(:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    IF (.NOT. PRESENT(weight)) THEN
      sigma_1D = SIGMA_4D(RESHAPE(x(:),N(:)),MASK=mask4D(:,:,:,:))
    ELSE
      sigma_1D = SIGMA_4D(RESHAPE(x(:),N(:)),WEIGHT=RESHAPE(weight(:),N(:)), &
                          MASK=mask4D(:,:,:,:))
    END IF
  END FUNCTION sigma_1D

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

  ! 4D dim
  PURE FUNCTION sigma_4D_dim (x,dim,mask)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL:: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(3,2,dim == 1 .OR. dim == 2)), &
                        SIZE(x,MERGE(3,4,dim == 4))) :: sigma_4D_dim

    INTEGER :: i1, i2, i3, i4, N1, N2, N3, N4
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)) :: mask4D

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

    N1 = SIZE(x(:,:,:,:),1)
    N2 = SIZE(x(:,:,:,:),2)
    N3 = SIZE(x(:,:,:,:),3)
    N4 = SIZE(x(:,:,:,:),4)
    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,:) = mask(:,:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        FORALL (i2=1:N2,i3=1:N3,i4=1:N4) &
          sigma_4D_dim(i2,i3,i4) = SIGMA_1D(x(:,i2,i3,i4), &
                                            MASK=mask4D(:,i2,i3,i4))
      CASE (2)
        FORALL (i1=1:N1,i3=1:N3,i4=1:N4) &
          sigma_4D_dim(i1,i3,i4) = SIGMA_1D(x(i1,:,i3,i4), &
                                            MASK=mask4D(i1,:,i3,i4))
      CASE (3)
        FORALL (i1=1:N1,i2=1:N2,i4=1:N4) &
          sigma_4D_dim(i1,i2,i4) = SIGMA_1D(x(i1,i2,:,i4), &
                                            MASK=mask4D(i1,i2,:,i4))
      CASE (4)
        FORALL (i1=1:N1,i2=1:N2,i3=1:N3) &
          sigma_4D_dim(i1,i2,i3) = SIGMA_1D(x(i1,i2,i3,:), &
                                            MASK=mask4D(i1,i2,i3,:))
    END SELECT

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

  END FUNCTION sigma_4D_dim

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

  ! 3D dim
  PURE FUNCTION sigma_3D_dim (x,dim,mask)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(2,3,dim == 3))) :: sigma_3D_dim

    INTEGER :: i1, i2, i3, N1, N2, N3
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)) :: mask3D

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

    N1 = SIZE(x(:,:,:),1)
    N2 = SIZE(x(:,:,:),2)
    N3 = SIZE(x(:,:,:),3)
    IF (PRESENT(mask)) THEN ; mask3D(:,:,:) = mask(:,:,:)
                       ELSE ; mask3D(:,:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        FORALL (i2=1:N2,i3=1:N3) &
          sigma_3D_dim(i2,i3) = SIGMA_1D(x(:,i2,i3),MASK=mask3D(:,i2,i3))
      CASE (2)
        FORALL (i1=1:N1,i3=1:N3) &
          sigma_3D_dim(i1,i3) = SIGMA_1D(x(i1,:,i3),MASK=mask3D(i1,:,i3))
      CASE (3)
        FORALL (i1=1:N1,i2=1:N2) &
          sigma_3D_dim(i1,i2) = SIGMA_1D(x(i1,i2,:),MASK=mask3D(i1,i2,:))
    END SELECT

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

  END FUNCTION sigma_3D_dim

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

  ! 2D dim
  PURE FUNCTION sigma_2D_dim (x,dim,mask)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1))) :: sigma_2D_dim

    INTEGER :: i1, i2, N1, N2
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)) :: mask2D

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

    N1 = SIZE(x(:,:),1)
    N2 = SIZE(x(:,:),2)
    IF (PRESENT(mask)) THEN ; mask2D(:,:) = mask(:,:)
                       ELSE ; mask2D(:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        FORALL (i2=1:N2) &
          sigma_2D_dim(i2) = SIGMA_1D(x(:,i2),MASK=mask2D(:,i2))
      CASE (2)
        FORALL (i1=1:N1) &
          sigma_2D_dim(i1) = SIGMA_1D(x(i1,:),MASK=mask2D(i1,:))
    END SELECT

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

  END FUNCTION sigma_2D_dim

  !==========================================================================
  ! m(X) = MOMENT_DATA(X[N],order,weight[N])
  !
  !   Computes the orderieth moment of the variable X, with weights w. If
  ! w is not supplied then the distribution is assumed to be uniform.
  !==========================================================================

  FUNCTION moment_data (x,order,weight)

    USE utilities, ONLY: DP, strike, flEQ, warning
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    INTEGER, INTENT(IN) :: order
    REAL(DP), INTENT(IN), DIMENSION(:), OPTIONAL :: weight
    REAL(DP) :: moment_data

    INTEGER :: N
    REAL(DP) :: norm, mean
    REAL(DP), DIMENSION(SIZE(x)) :: w

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

    ! Check input
    N = SIZE(x)
    IF (PRESENT(weight)) THEN
      w = weight
    ELSE
      w = SPREAD(1._DP/N,1,N)
    END IF
    IF (SIZE(w) /= N) CALL STRIKE ("MOMENT_DATA","bad input.")

    ! Check normalisation if order>0, otherwise the function returns the
    ! normalisation factor.
    normalisation: IF (order > 0) THEN
      norm = SUM(w)
      IF (.NOT. flEQ(norm,1._DP,TOL=1.E-2_DP)) &
        CALL WARNING ("MOMENT_DATA","the distribution was not normalised.")
      w = w/norm
    ELSE IF (order < 0) THEN
      CALL STRIKE ("MOMENT_DATA","order must be positive or zero.")
    END IF normalisation

    ! Compute the moments
    moment: SELECT CASE (order-1)
      CASE (:-1)
        moment_data = SUM(w)
      CASE (0)
        moment_data = SUM(x*w)
      CASE (+1:)
        mean = SUM(x*w)
        moment_data = SUM((x-mean)**order*w)
    END SELECT moment

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

  END FUNCTION moment_data

  !==========================================================================
  ! m = MEDIAN_DATA(X[1D to 4D],dim=,mask)
  !     MEDIAN_DATA(X[N],weight[N],mask)
  !
  !   Computes the median of a variable X, using part of the Hoare sorting
  ! method. If the weight W is not supplied then the distribution is assumed
  ! to be uniform.
  !==========================================================================

  FUNCTION median_data_4D (x,mask)

    USE utilities, ONLY: DP
    USE arrays, ONLY: sort
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: median_data_4D

    INTEGER :: N
    REAL(DP), DIMENSION(SIZE(x)) :: xs
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)) :: mask4D

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

    ! Mask
    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,:) = mask(:,:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF

    ! Sort the arrays
    N = COUNT(mask4D(:,:,:,:))
    xs(:) = SORT(PACK(x(:,:,:,:),MASK=mask4D(:,:,:,:)))

    ! Even / odd cases
    median_data_4D = MERGE( (xs(N/2) + xs(N/2+1)) / 2._DP, &
                            xs(N/2+1), ( MOD(N,2) == 0 ) )

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

  END FUNCTION median_data_4D

  ! Interface
  FUNCTION median_data_3D (x,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP) :: median_data_3D
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),1) :: mask4D
    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,1) = mask(:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    median_data_3D = MEDIAN_DATA_4D(RESHAPE(x(:,:,:), &
                                            [SIZE(x,1),SIZE(x,2),SIZE(x,3),1]),&
                                    MASK=mask4D(:,:,:,:))
  END FUNCTION median_data_3D
  FUNCTION median_data_2D (x,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: median_data_2D
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),1,1) :: mask4D
    IF (PRESENT(mask)) THEN ; mask4D(:,:,1,1) = mask(:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    median_data_2D = MEDIAN_DATA_4D(RESHAPE(x(:,:),[SIZE(x,1),SIZE(x,2),1,1]), &
                                    MASK=mask4D(:,:,:,:))
  END FUNCTION median_data_2D
  FUNCTION median_data_1D (x,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: x
    LOGICAL, DIMENSION(SIZE(x)), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: median_data_1D
    LOGICAL, DIMENSION(SIZE(x),1,1,1) :: mask4D
    IF (PRESENT(mask)) THEN ; mask4D(:,1,1,1) = mask(:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    median_data_1D = MEDIAN_DATA_4D(RESHAPE(x(:),[SIZE(x,1),1,1,1]), &
                                    MASK=mask4D(:,:,:,:))
  END FUNCTION median_data_1D

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

  FUNCTION median_data_4D_dim (x,dim,mask)

    USE utilities, ONLY: DP, strike, NaN
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(3,2,dim == 1 .OR. dim == 2)), &
                        SIZE(x,MERGE(3,4,dim == 4))) :: median_data_4D_dim

    INTEGER :: i1, i2, i3, i4
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)) :: mask4D

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

    IF (PRESENT(mask)) THEN ; mask4D(:,:,:,:) = mask(:,:,:,:)
                       ELSE ; mask4D(:,:,:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        DO i2=1,SIZE(x(:,:,:,:),2)
          DO i3=1,SIZE(x(:,:,:,:),3)
            DO i4=1,SIZE(x(:,:,:,:),4)
              median_data_4D_dim(i2,i3,i4) = MEDIAN_DATA_1D(x(:,i2,i3,i4), &
                                                        MASK=mask4D(:,i2,i3,i4))
            END DO
          END DO
        END DO
      CASE (2)
        DO i1=1,SIZE(x(:,:,:,:),1)
          DO i3=1,SIZE(x(:,:,:,:),3)
            DO i4=1,SIZE(x(:,:,:,:),4)
              median_data_4D_dim(i1,i3,i4) = MEDIAN_DATA_1D(x(i1,:,i3,i4), &
                                                        MASK=mask4D(i1,:,i3,i4))
            END DO
          END DO
        END DO
      CASE (3)
        DO i1=1,SIZE(x(:,:,:,:),1)
          DO i2=1,SIZE(x(:,:,:,:),2)
            DO i4=1,SIZE(x(:,:,:,:),4)
              median_data_4D_dim(i1,i2,i4) = MEDIAN_DATA_1D(x(i1,i2,:,i4), &
                                                        MASK=mask4D(i1,i2,:,i4))
            END DO
          END DO
        END DO
      CASE (4)
        DO i1=1,SIZE(x(:,:,:,:),1)
          DO i2=1,SIZE(x(:,:,:,:),2)
            DO i3=1,SIZE(x(:,:,:,:),3)
              median_data_4D_dim(i1,i2,i3) = MEDIAN_DATA_1D(x(i1,i2,i3,:), &
                                                        MASK=mask4D(i1,i2,i3,:))
            END DO
          END DO
        END DO
      CASE DEFAULT
        median_data_4D_dim(:,:,:) = NaN()
        CALL STRIKE("MEDIAN_DATA","Wrong value for keyword DIM")
    END SELECT

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

  END FUNCTION median_data_4D_dim

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

  FUNCTION median_data_3D_dim (x,dim,mask)

    USE utilities, ONLY: DP, strike, NaN
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)), INTENT(IN), &
      OPTIONAL :: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1)), &
                        SIZE(x,MERGE(2,3,dim == 3))) :: median_data_3D_dim

    INTEGER :: i1, i2, i3
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)) :: mask3D

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

    IF (PRESENT(mask)) THEN ; mask3D(:,:,:) = mask(:,:,:)
                       ELSE ; mask3D(:,:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        DO i2=1,SIZE(x(:,:,:),2)
          DO i3=1,SIZE(x(:,:,:),3)
            median_data_3D_dim(i2,i3) = MEDIAN_DATA_1D(x(:,i2,i3), &
                                                       MASK=mask3D(:,i2,i3))
          END DO
        END DO
      CASE (2)
        DO i1=1,SIZE(x(:,:,:),1)
          DO i3=1,SIZE(x(:,:,:),3)
            median_data_3D_dim(i1,i3) = MEDIAN_DATA_1D(x(i1,:,i3), &
                                                       MASK=mask3D(i1,:,i3))
          END DO
        END DO
      CASE (3)
        DO i1=1,SIZE(x(:,:,:),1)
          DO i2=1,SIZE(x(:,:,:),2)
            median_data_3D_dim(i1,i2) = MEDIAN_DATA_1D(x(i1,i2,:), &
                                                       MASK=mask3D(i1,i2,:))
          END DO
        END DO
      CASE DEFAULT
        median_data_3D_dim(:,:) = NaN()
        CALL STRIKE("MEDIAN_DATA","Wrong value for keyword DIM")
    END SELECT

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

  END FUNCTION median_data_3D_dim

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

  FUNCTION median_data_2D_dim (x,dim,mask)

    USE utilities, ONLY: DP, strike, NaN
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    INTEGER, INTENT(IN) :: dim
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)), INTENT(IN), OPTIONAL :: mask
    REAL(DP), DIMENSION(SIZE(x,MERGE(2,1,dim == 1))) :: median_data_2D_dim

    INTEGER :: i1, i2
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)) :: mask2D

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

    IF (PRESENT(mask)) THEN ; mask2D(:,:) = mask(:,:)
                       ELSE ; mask2D(:,:) = .True. ; END IF
    SELECT CASE (dim)
      CASE (1)
        DO i2=1,SIZE(x(:,:),2)
          median_data_2D_dim(i2) = MEDIAN_DATA_1D(x(:,i2),MASK=mask2D(:,i2))
        END DO
      CASE (2)
        DO i1=1,SIZE(x(:,:),1)
          median_data_2D_dim(i1) = MEDIAN_DATA_1D(x(i1,:),MASK=mask2D(i1,:))
        END DO
      CASE DEFAULT
        median_data_2D_dim(:) = NaN()
        CALL STRIKE("MEDIAN_DATA","Wrong value for keyword DIM")
    END SELECT

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

  END FUNCTION median_data_2D_dim

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

  FUNCTION median_data_wei (x,weight)

    USE utilities, ONLY: DP, strike, flEQ, warning
    USE arrays, ONLY: sort, closest
    USe interpolation, ONLY: interp_lin_sorted
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN), DIMENSION(:) :: weight
    REAL(DP) :: median_data_wei

    INTEGER :: N, i, Nun
    REAL(DP) :: norm
    INTEGER, DIMENSION(SIZE(x)) :: ind
    REAL(DP), DIMENSION(SIZE(x)) :: xs, ws, F
    LOGICAL, DIMENSION(SIZE(x)) :: uniq

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

    ! Check input
    N = SIZE(x)
    ws = weight
    IF (SIZE(ws) /= N) CALL STRIKE ("MEDIAN_DATA","bad input.")

    ! Check normalisation
    norm = SUM(ws)
    IF (.NOT. flEQ(norm,1._DP,TOL=1.E-2_DP)) &
      CALL WARNING ("MEDIAN_DATA","the distribution was not normalised.")
    ws = ws / norm

    ! Sort the arrays
    xs = SORT(x,IND=ind)
    ws = ws(ind)

    ! Repartition function (cumulate the duplicate values in one bin)
    F(1) = 0._DP
    uniq = .True.
    DO i=2,N
      F(i) = F(i-1) + ws(i)
      uniq(i-1) = MERGE(.True.,.False.,xs(i) > xs(i-1))
    END DO

    ! Interpolation to get a good estimate of the median
    Nun = COUNT(uniq)
    IF (Nun == 1) THEN
      median_data_wei = x(1)
    ELSE
      median_data_wei = INTERP_LIN_SORTED(xs(:),F(:),0.5_DP)
    END IF

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

  END FUNCTION median_data_wei

  !==========================================================================
  ! CALL MEDIAN_CONF(X[1-4D],CONF=0.99,x0,dxinf,dxsup)
  !
  !   Computes the median of a variable X, and the lower and upper limits
  ! corresponding to a confidence inter val of CONF.
  !==========================================================================

  SUBROUTINE median_conf_4D (x,conf,x0,dxinf,dxsup)

    USE utilities, ONLY: DP
    USE arrays, ONLY: sort
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:,:,:) :: x
    REAL(DP), INTENT(IN) :: conf
    REAL(DP), INTENT(OUT) :: x0, dxinf, dxsup

    INTEGER :: N, N0, Ninf, Nsup
    INTEGER, DIMENSION(SIZE(x)) :: ind
    REAL(DP), DIMENSION(SIZE(x)) :: xs

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

    ! Sort the arrays
    N = SIZE(x(:,:,:,:))
    xs(:) = SORT(RESHAPE(x(:,:,:,:),[N]),IND=ind)

    ! Even / odd cases
    N0 = N / 2
    x0 = MERGE( (xs(N0) + xs(N0+1)) / 2._DP, xs(N0+1), ( MOD(N,2) == 0 ) )
    Ninf = NINT( (1._DP-conf)/2._DP * N )
    Nsup = NINT( (1._DP+conf)/2._DP * N )
    dxinf = x0 - xs(Ninf)
    dxsup = xs(Nsup) - x0

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

  END SUBROUTINE median_conf_4D

  ! 3D
  SUBROUTINE median_conf_3D (x,conf,x0,dxinf,dxsup)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), DIMENSION(:,:,:) :: x
    REAL(DP), INTENT(IN) :: conf
    REAL(DP), INTENT(OUT) :: x0, dxinf, dxsup
    INTEGER :: N1, N2, N3
    N1 = SIZE(x(:,:,:),1)
    N2 = SIZE(x(:,:,:),2)
    N3 = SIZE(x(:,:,:),3)
    CALL MEDIAN_CONF_4D(RESHAPE(x(:,:,:),[N1,N2,N3,1]),conf,x0,dxinf,dxsup)
  END SUBROUTINE median_conf_3D

  ! 2D
  SUBROUTINE median_conf_2D (x,conf,x0,dxinf,dxsup)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), DIMENSION(:,:) :: x
    REAL(DP), INTENT(IN) :: conf
    REAL(DP), INTENT(OUT) :: x0, dxinf, dxsup
    INTEGER :: N1, N2
    N1 = SIZE(x(:,:),1)
    N2 = SIZE(x(:,:),2)
    CALL MEDIAN_CONF_4D(RESHAPE(x(:,:),[N1,N2,1,1]),conf,x0,dxinf,dxsup)
  END SUBROUTINE median_conf_2D

  ! 1D
  SUBROUTINE median_conf_1D (x,conf,x0,dxinf,dxsup)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: conf
    REAL(DP), INTENT(OUT) :: x0, dxinf, dxsup
    INTEGER :: N1
    N1 = SIZE(x(:),1)
    CALL MEDIAN_CONF_4D(RESHAPE(x(:),[N1,1,1,1]),conf,x0,dxinf,dxsup)
  END SUBROUTINE median_conf_1D

  !==========================================================================
  ! CALL INFO_DATA (X[N],WEIGHT[N],name)
  !
  !   Computes the basic statistical quantities of a set of data.
  !==========================================================================

  SUBROUTINE info_data_1D (x,weight,name)

    USE utilities, ONLY: DP, trimLR
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN), DIMENSION(:), OPTIONAL :: weight
    CHARACTER(*), INTENT(IN), OPTIONAL :: name

    INTEGER, PARAMETER :: l=20

    INTEGER :: N
    CHARACTER(l) :: title
    REAL(DP) :: xinf, xsup, xmean, sigx
    REAL(DP), DIMENSION(SIZE(x)) :: w

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

    ! Computes the quantities
    N = SIZE(x)
    xinf = MINVAL(x)
    xsup = MAXVAL(x)
    IF (PRESENT(weight)) THEN
      w = weight
    ELSE
      w = SPREAD(1._DP/N,1,N)
    END IF
    xmean = MOMENT_DATA(x,ORDER=1,WEIGHT=w)
    sigx = SQRT(MOMENT_DATA(x,ORDER=2,WEIGHT=w))

    ! Print the summary
    IF (PRESENT(name)) THEN
      title = name
    ELSE
      title = REPEAT(" ",l)
    END IF
    PRINT*, " => INFO_DATA: "//TRIMLR(title)//" = ",xmean,"+-",sigx
    PRINT*, "               "//TRIMLR(title)//" in [",xinf,",",xsup,"]"
    PRINT*, "               "//TRIMLR(title)//" has ",N," elements."

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

  END SUBROUTINE info_data_1D

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

  SUBROUTINE info_data_2D (x,name)

    USE utilities, ONLY: DP, trimLR
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: x
    CHARACTER(*), INTENT(IN), OPTIONAL :: name

    INTEGER, PARAMETER :: l=20

    INTEGER :: N, N1, N2
    CHARACTER(l) :: title
    REAL(DP) :: xinf, xsup, xmean, sigx

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

    ! Computes the quantities
    N = SIZE(x)
    N1 = SIZE(x,1)
    N2 = SIZE(x,2)
    xinf = MINVAL(x)
    xsup = MAXVAL(x)
    xmean = MOMENT_DATA(RESHAPE(x,SHAPE=(/N/)),ORDER=1)
    sigx = SQRT(MOMENT_DATA(RESHAPE(x,SHAPE=(/N/)),ORDER=2))

    ! Print the summary
    IF (PRESENT(name)) THEN
      title = name
    ELSE
      title = REPEAT(" ",l)
    END IF
    PRINT*, " => INFO_DATA: "//TRIMLR(title)//" = ",xmean,"+-",sigx
    PRINT*, "               "//TRIMLR(title)//" in [",xinf,",",xsup,"]"
    PRINT*, "               "//TRIMLR(title)//" has the profile [",N1,N2,"]"

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

  END SUBROUTINE info_data_2D

  !==========================================================================
  ! fwhm = FWHM_DATA(x[N],F[X])
  !
  !   Computes the full width at half maximum of any distribution. The
  ! distribution is supposed to be monomodal and well sampled.
  !==========================================================================

  FUNCTION fwhm_data (x,F)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:) :: x, F
    REAL(DP) :: fwhm_data

    INTEGER :: Nhm
    REAL(DP) :: hm
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xhm

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

    hm = MAXVAL(F)/2._DP
    Nhm = COUNT(F>=hm)
    ALLOCATE(xhm(Nhm))
    xhm = PACK(x,F>=hm)

    fwhm_data = MAXVAL(xhm) - MINVAL(xhm)
    DEALLOCATE (xhm)

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

  END FUNCTION fwhm_data

  !==========================================================================
  ! corr[Ncorr] = RMAT2CORR(Rmat[Npar,Npar],Npar,Ncorr)
  !
  !   Extract the correlation coefficients from the correlation matrix.
  !==========================================================================

  PURE FUNCTION Rmat2corr_DP (Rmat,Npar,Ncorr)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(Npar,Npar), INTENT(IN) :: Rmat
    INTEGER, INTENT(IN) :: Npar, Ncorr
    REAL(DP), DIMENSION(Ncorr) :: Rmat2corr_DP

    INTEGER :: i, j, k

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

    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (MERGE(j > i,i > j,upper)) THEN
          Rmat2corr_DP(k) = Rmat(i,j)
          k = k + 1
        END IF
      END DO
    END DO

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

  END FUNCTION Rmat2corr_DP

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

  PURE FUNCTION Rmat2corr_log (Rmat,Npar,Ncorr)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    LOGICAL, DIMENSION(Npar,Npar), INTENT(IN) :: Rmat
    INTEGER, INTENT(IN) :: Npar, Ncorr
    LOGICAL, DIMENSION(Ncorr) :: Rmat2corr_log

    INTEGER :: i, j, k

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

    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (MERGE(j > i,i > j,upper)) THEN
          Rmat2corr_log(k) = Rmat(i,j)
          k = k + 1
        END IF
      END DO
    END DO

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

  END FUNCTION Rmat2corr_log

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

  PURE FUNCTION Rmat2corr_char (Rmat,Npar,Ncorr)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    CHARACTER(*), DIMENSION(Npar,Npar), INTENT(IN) :: Rmat
    INTEGER, INTENT(IN) :: Npar, Ncorr
    CHARACTER(LEN(Rmat)), DIMENSION(Ncorr) :: Rmat2corr_char

    INTEGER :: i, j, k

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

    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (MERGE(j > i,i > j,upper)) THEN
          Rmat2corr_char(k) = Rmat(i,j)
          k = k + 1
        END IF
      END DO
    END DO

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

  END FUNCTION Rmat2corr_char

  !==========================================================================
  ! Rmat[Npar,Npar] = CORR2RMAT(corr[Ncorr],Npar)
  !
  !   Build a correlation matrix, from the correlation coefficients.
  !==========================================================================

  PURE FUNCTION corr2Rmat_DP (corr,Npar)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: corr
    INTEGER, INTENT(IN) :: Npar
    REAL(DP), DIMENSION(Npar,Npar) :: corr2Rmat_DP

    INTEGER :: i, j, k

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

    ! Upper and lower triangles
    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (j > i) THEN
          corr2Rmat_DP(i,j) = corr(k)
          corr2Rmat_DP(j,i) = corr(k)
          k = k + 1
        END IF
      END DO
    END DO

    ! Diagonal
    FORALL (i=1:Npar) corr2Rmat_DP(i,i) = 1._DP

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

  END FUNCTION corr2Rmat_DP

  !==========================================================================
  ! corr[Ncorr] = VMAT2CORR(Vmat[Npar,Npar],Npar,Ncorr)
  !
  !   Extract the correlation coefficients from the covariance matrix.
  !==========================================================================

  PURE FUNCTION Vmat2corr (Vmat,Npar,Ncorr)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(Npar,Npar), INTENT(IN) :: Vmat
    INTEGER, INTENT(IN) :: Npar, Ncorr
    REAL(DP), DIMENSION(Ncorr) :: Vmat2corr

    INTEGER :: i, j, k
    REAL(DP), DIMENSION(Npar) :: sig

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

    FORALL (i=1:Npar) sig(i) = SQRT(Vmat(i,i))
    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (MERGE(j > i,i > j,upper)) THEN
          Vmat2corr(k) = Vmat(i,j) / sig(i) / sig(j)
          k = k + 1
        END IF
      END DO
    END DO

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

  END FUNCTION Vmat2corr

  !==========================================================================
  ! CALL CORREL_INDEX(Npar,Ncorr,icorr2ij)
  !
  !   Returns the pair of parameter inidices corresponding to unique correlation
  ! coefficients.
  !==========================================================================

  SUBROUTINE correl_index (Npar,Ncorr,icorr2ij)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Npar, Ncorr
    INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: icorr2ij

    INTEGER :: i, j, k

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

    ALLOCATE (icorr2ij(Ncorr,2))
    k = 1
    DO i=1,Npar
      DO j=1,Npar
        IF (MERGE(j > i,i > j,upper)) THEN
          icorr2ij(k,:) = [ i, j ]
          k = k + 1
        END IF
      END DO
    END DO

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

  END SUBROUTINE correl_index

  !==========================================================================
  ! Ncorr = N_CORR(Npar)
  !
  !   Number of unique correlations for Npar parameters.
  !==========================================================================

  FUNCTION N_corr (Npar)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: Npar
    INTEGER :: N_corr

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

    N_corr = NINT( REAL(Npar*(Npar-1))/2._DP )

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

  END FUNCTION N_corr

  !==========================================================================
  ! r = CORRELATE(x[N],y[N])
  !
  !   Computes the Pearson correlation coefficient of two arrays.
  !==========================================================================

  PURE FUNCTION correlate_4D (x,y,mask)

    USE utilities, ONLY: DP, tinyDP
    USE special_functions, ONLY: ibeta
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:,:), INTENT(IN) :: x, y
    LOGICAL, DIMENSION(:,:,:,:), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: correlate_4D

    REAL(DP) :: N, ax, ay, sxx, sxy, syy
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3),SIZE(x,4)) :: mask0

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

    mask0(:,:,:,:) = .True.
    IF (PRESENT(mask)) mask0(:,:,:,:) = mask(:,:,:,:)
    N = COUNT(mask0(:,:,:,:))
    ax = SUM(x(:,:,:,:),MASK=mask0(:,:,:,:)) / N
    ay = SUM(y(:,:,:,:),MASK=mask0(:,:,:,:)) / N
    sxx = SUM((x(:,:,:,:)-ax)**2,MASK=mask0(:,:,:,:)) / (N-1)
    syy = SUM((y(:,:,:,:)-ay)**2,MASK=mask0(:,:,:,:)) / (N-1)
    sxy = SUM((x(:,:,:,:)-ax)*(y(:,:,:,:)-ay),MASK=mask0(:,:,:,:)) / (N-1)
    correlate_4D = sxy / (SQRT(sxx*syy) + tinyDP)

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

  END FUNCTION correlate_4D

  ! 3D interface
  PURE FUNCTION correlate_3D(x,y,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:,:), INTENT(IN) :: x, y
    LOGICAL, DIMENSION(:,:,:), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: correlate_3D
    INTEGER :: N1, N2, N3
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2),SIZE(x,3)) :: mask0
    N1 = SIZE(x(:,:,:),1)
    N2 = SIZE(x(:,:,:),2)
    N3 = SIZE(x(:,:,:),3)
    mask0(:,:,:) = .True.
    IF (PRESENT(mask)) mask0(:,:,:) = mask(:,:,:)
    correlate_3D = CORRELATE_4D(RESHAPE(x(:,:,:),[N1,N2,N3,1]), &
                                RESHAPE(y(:,:,:),[N1,N2,N3,1]), &
                                MASK=RESHAPE(mask0(:,:,:),[N1,N2,N3,1]))
  END FUNCTION correlate_3D

  ! 2D interface
  PURE FUNCTION correlate_2D(x,y,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x, y
    LOGICAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: correlate_2D
    INTEGER :: N1, N2
    LOGICAL, DIMENSION(SIZE(x,1),SIZE(x,2)) :: mask0
    N1 = SIZE(x(:,:),1)
    N2 = SIZE(x(:,:),2)
    mask0(:,:) = .True.
    IF (PRESENT(mask)) mask0(:,:) = mask(:,:)
    correlate_2D = CORRELATE_4D(RESHAPE(x(:,:),[N1,N2,1,1]), &
                                RESHAPE(y(:,:),[N1,N2,1,1]), &
                                MASK=RESHAPE(mask0(:,:),[N1,N2,1,1]))
  END FUNCTION correlate_2D

  ! 1D interface
  PURE FUNCTION correlate_1D(x,y,mask)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: x, y
    LOGICAL, DIMENSION(:), INTENT(IN), OPTIONAL :: mask
    REAL(DP) :: correlate_1D
    INTEGER :: N1
    LOGICAL, DIMENSION(SIZE(x)) :: mask0
    N1 = SIZE(x(:),1)
    mask0(:) = .True.
    IF (PRESENT(mask)) mask0(:) = mask(:)
    correlate_1D = CORRELATE_4D(RESHAPE(x(:),[N1,1,1,1]), &
                                RESHAPE(y(:),[N1,1,1,1]), &
                                MASK=RESHAPE(mask0(:),[N1,1,1,1]))
  END FUNCTION correlate_1D

  !==========================================================================
  ! CALL CORREL_PARLIST(x[N,Npar]IN,rho[N_CORR(Npar)]OUT)
  !
  !   Computes all the non-trivial correlation coefficients among a list of
  ! parameters. If the parmaters are CHARACTER, then the correlation name is
  ! built.
  !==========================================================================

  SUBROUTINE correl_parlist_DP (par,corr)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: par
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: corr

    INTEGER :: i, j, N, Npar, Ncorr
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: Rmat

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

    N = SIZE(par(:,:),1)
    Npar = SIZE(par(:,:),2)
    Ncorr = N_CORR(Npar)
    ALLOCATE (Rmat(Npar,Npar))
    FORALL (i=1:Npar,j=1:Npar,MERGE(j > i,i > j,upper)) &
      Rmat(i,j) = CORRELATE(par(:,i),par(:,j))
    ALLOCATE (corr(Ncorr))
    corr(:) = RMAT2CORR(Rmat(:,:),Npar,Ncorr)
    DEALLOCATE (Rmat)

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

  END SUBROUTINE correl_parlist_DP

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

  SUBROUTINE correl_parlist_char (par,corr)

    USE utilities, ONLY: DP, trimlr, lenmax
    IMPLICIT NONE

    CHARACTER(*), DIMENSION(:), INTENT(IN) :: par
    CHARACTER(*), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: corr

    INTEGER :: i, j, Npar, Ncorr
    CHARACTER(lenmax), DIMENSION(:,:), ALLOCATABLE :: Rmat

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

    Npar = SIZE(par(:))
    Ncorr = N_CORR(Npar)
    ALLOCATE (Rmat(Npar,Npar))
    FORALL (i=1:Npar,j=1:Npar,MERGE(j > i,i > j,upper)) &
      Rmat(i,j) = TRIMLR(par(i))//"-"//TRIMLR(par(j))
    ALLOCATE (corr(Ncorr))
    corr(:) = RMAT2CORR(Rmat(:,:),Npar,Ncorr)
    DEALLOCATE (Rmat)

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

  END SUBROUTINE correl_parlist_char

  !==========================================================================
  ! CALL AUTOCORREL(data[N],rho[Nlag],Nlag)
  !
  !   Computes the reduced autocorrelation function of a time serie, as a
  ! a function of positive lag [1,Nlag].
  !==========================================================================

  SUBROUTINE autocorrel (data,rho,Nlag)

    USE utilities, ONLY: DP
    USE FFT_specials, ONLY: correl
    IMPLICIT NONE
    REAL(DP), DIMENSION(:), INTENT(IN) :: data
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: rho
    INTEGER, INTENT(OUT), OPTIONAL :: Nlag

    INTEGER :: Ndata, Nacf, Nl
    REAL(DP) :: meandata, vardata
    REAL(DP), DIMENSION(:), ALLOCATABLE :: acf, dat

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

    ! Properties of the time serie
    Ndata = SIZE(data)
    meandata = MEAN(data)
    vardata = (SIGMA(data))**2

    ! Raw autocorrelation
    Nacf = 2**(FLOOR(LOG(REAL(Ndata,DP))/LOG(2._DP)))
    ALLOCATE (acf(Nacf),dat(Nacf))
    dat(:) = data(1:Nacf) - meandata
    acf(:) = CORREL(dat(:),dat(:))

    ! Normalization
    Nl = Nacf / 2
    ALLOCATE (rho(Nl))
!    rho(:) = ( acf(1:Nl) - meandata**2 ) / vardata
    rho(:) = acf(1:Nl) / acf(1)
    IF (PRESENT(Nlag)) Nlag = Nl
    DEALLOCATE(acf,dat)

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

  END SUBROUTINE autocorrel

  !==========================================================================
  ! t_int = INTAUTOCORRTIME(acf[Nlag],Nmcmc,Neff(OUT,OPT),low(OPT),high(OPT), &
  !                         step(OPT),c(OPT),FORCE=T/F)
  !
  !   Computes the integrated autocorrelation time, following the method by
  ! Sokal (http://www.stat.unc.edu/faculty/cji/Sokal.pdf), as implemented in
  ! Emcee (https://github.com/dfm/emcee/blob/master/emcee/autocorr.py).
  !   RHO[Nlag] is the precomputed ACF and Nmcmc the length of the chain, both
  ! after burn-in.
  !   LOW is the minimum window size to test (default = 10).
  !   HIGH is the maximum window size to test (default = Nmcmc/(2c)).
  !   STEP is the step size for the window search (default = 1).
  !   C is the minimum number of autocorrelation times needed to trust the
  ! estimate (default = 10).
  !==========================================================================

  FUNCTION intautocorrtime (acf,Nmcmc,Neff,low,high,step,c,warn,force)

    USE utilities, ONLY: DP, warning, warnings, hugeDP
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: acf
    INTEGER, INTENT(IN) :: Nmcmc
    INTEGER, INTENT(OUT), OPTIONAL :: Neff
    INTEGER, INTENT(IN), OPTIONAL :: low, high, step
    REAL(DP), INTENT(IN), OPTIONAL :: c
    LOGICAL, INTENT(IN), OPTIONAL :: warn, force
    REAL(DP) :: intautocorrtime

    INTEGER :: siz, low0, high0, step0, m
    REAL(DP) :: c0, tau
    LOGICAL :: warn0, force0

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

    ! Default values
    siz = NINT(Nmcmc/2._DP)
    IF (PRESENT(warn)) THEN ; warn0 = warn ; ELSE ; warn0 = warnings ; END IF
    IF (PRESENT(force)) THEN ; force0 = force ; ELSE ; force0 = .False. ; END IF
    IF (PRESENT(low)) THEN ; low0 = low ; ELSE ; low0 = 10 ; END IF
    IF (PRESENT(c)) THEN ; c0 = c ; ELSE ; c0 = 10._DP ; END IF
    IF (PRESENT(high)) THEN ; high0 = high
                       ELSE ; high0 = NINT(Nmcmc/(2*c0)) ; END IF
    IF (PRESENT(step)) THEN ; step0 = step ; ELSE ; step0 = 1 ; END IF
    IF (NINT(c0*low0) >= siz) THEN
      IF (warn0) CALL WARNING("INTAUTOCORRTIME","The chain is too short")
      intautocorrtime = hugeDP
      IF (PRESENT(Neff)) Neff = 0
      RETURN
    END IF

    ! Loop over proposed window sizes until convergence is reached
    DO m=low0,high0,step0
      ! Compute the autocorrelation time with the given window
      tau = 1 + 2 * SUM(acf(1:m)) / acf(1)
      ! Accept the window size if it satisfies the convergence criterion
      IF (tau > 1._DP .AND. m > c0*tau) THEN
        intautocorrtime = tau
        IF (PRESENT(Neff)) Neff = NINT(Nmcmc/tau)
        RETURN
      ELSE IF (c0*tau >= siz) THEN
        IF (warn0) CALL WARNING("INTAUTOCORRTIME", &
                            "The chain is too short to reliably estimate the " &
                            //"autocorrelation time")
        IF (force0) THEN ! make t_int negative to flag it as unreliable
          intautocorrtime = - ( 1 + 2 * SUM(acf(:)) / acf(1) )
          IF (PRESENT(Neff)) Neff = NINT(Nmcmc/intautocorrtime)
        ELSE
          intautocorrtime = hugeDP
          IF (PRESENT(Neff)) Neff = 0
        END IF
        RETURN
      END IF
    END DO

    ! To quiet the compiler
    IF (force0) THEN ! make t_int negative to flag it as unreliable
      intautocorrtime = - ( 1 + 2 * SUM(acf(:)) / acf(1) )
      IF (PRESENT(Neff)) Neff = NINT(Nmcmc/intautocorrtime)
    ELSE
      intautocorrtime = hugeDP
      IF (PRESENT(Neff)) Neff = 0
    END IF
    RETURN

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

  END FUNCTION intautocorrtime

END MODULE statistics


real*8 function MakeGridPoint(cilm, lmax, lat, longitude, norm, csphase)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will determine the value at a given latitude and
!	longitude corresponding to the given set of spherical harmonics.
!	Latitude and Longitude are assumed to be in DEGREES!
!
!	Calling Parameters:
!		IN
!			cilm:	Spherical harmonic coefficients, with dimensions
!				(2, lmax+1, lmax+1).
!			lmax:	Maximum degree used in the expansion.
!			lat:	latitude (degrees).
!			long:	longitude(degrees).
!		OPTIONAL (IN)
!			norm	Spherical harmonic normalization:
!					(1) "geodesy" (default)
!					(2) Schmidt
!					(3) unnormalized
!					(4) orthonormalized
!			csphase:	1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!
!
!	Dependencies:		PlmBar, PlBar, PlmSchmidt, PlmON, CSPHASE_DEFAULT
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PlmBar, PLegendreA, PlmSchmidt, PlmON, CSPHASE_DEFAULT

	implicit none

	real*8, intent(in):: 	cilm(:,:,:), lat, longitude
	integer, intent(in) ::	lmax
	integer, intent(in), optional ::	norm, csphase
	real*8 ::		pi, x, expand, lon, mlong
	integer ::		index, l, m, l1, m1, lmax_comp, phase, astat
	real*8, allocatable :: 	 pl(:)

	if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. size(cilm(1,1,:)) < lmax+1) then
		print*, "Error --- MakeGridPoint"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(norm)) then
		if (norm >4 .or. norm < 1) then
			print*, "Error - MakeGridPoint"
			print*, "Parameter NORM must be 1, 2, 3, or 4"
			stop
		endif
	endif

    	if (present(csphase)) then
     		if (csphase == -1) then
     			phase = -1.0d0
     		elseif (csphase == 1) then
     			phase = 1.0d0
     		else
     			print*, "Error --- MakeGridPoint"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		endif
     	else
     		phase = dble(CSPHASE_DEFAULT)
     	endif

     	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat)
     	if (astat /= 0) then
		print*, "Error --- MakeGridPoint"
		print*, "Problem allocating array PL", astat
		stop
	endif

	pi = acos(-1.0d0)
	x = sin(lat*pi/180.0d0)
	lon = longitude * pi/180.0d0

	lmax_comp = min(lmax, size(cilm(1,1,:))-1)

	if (present(norm)) then
		if (norm == 1) call PlmBar(pl, lmax_comp, x, csphase = phase)
		if (norm == 2) call PlmSchmidt(pl, lmax_comp, x, csphase = phase)
		if (norm == 3) call PLegendreA(pl, lmax_comp, x, csphase = phase)
		if (norm == 4) call PlmON(pl, lmax_comp, x, csphase = phase)
	else
		call PlmBar(pl, lmax_comp, x, csphase = phase)
	endif

	expand = 0.0d0

	do l = lmax_comp, 0, -1

		l1 = l+1
		index = (l+1)*l/2 + 1
		expand = expand + cilm(1,l1,1) * pl(index)

		do m = 1, l, 1
			m1 = m+1
			mlong = m*lon
			index = (l+1)*l/2 + m + 1
			expand = expand + ( cilm(1,l1,m1) * cos(mlong) + &
				cilm(2,l1,m1) * sin(mlong) ) * pl(index)
		enddo
	enddo

	MakeGridPoint = expand

	! deallocate memory
	if (present(norm)) then
		if (norm == 1) call PlmBar(pl, -1, x, csphase = phase)
		if (norm == 2) call PlmSchmidt(pl, -1, x, csphase = phase)
		if (norm == 4) call PlmON(pl, -1, x, csphase = phase)
	else
		call PlmBar(pl, -1, x, csphase = phase)
	endif
	deallocate(pl)

end function MakeGridPoint


subroutine coarse_to_fine_cvface(e_2h, e_h, nx, ny)
!use variables
use kind_parameters
implicit none

integer:: i, j, if, jf, ic, jc, nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: e_2h
real(kind=dp), intent(out), dimension(:,:):: e_h

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = 2,ny-2

    do i = 2,nx-2

        e_h(2*i-1,2*j-1) = (1.0/4.0)*(3.0*e_2h(i,j) + e_2h(i,j+1))
        e_h(2*i-1,2*j-1) = (1.0/16.0)*(9.0*e_2h(i+1,j) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j+1) + e_2h(i,j+1))
        e_h(2*i-1,2*j) = (1.0/16.0)*(9.0*e_2h(i,j+1) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j+1) + e_2h(i+1,j))
        e_h(2*i-1,2*j-1) = (1.0/16.0)*(9.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j+1))

    end do

end do

j = 1

    e_h(2,2*j) = (1.0/4.0)*(e_2h(1,j) + e_2h(1,j+1) + e_2h(2,j) + e_2h(2,j+1))

    do i = 2,nx-2

        e_h(2*i-1,2*j) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))
        e_h(2*i,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i,j+1) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i+1,j+1))

    end do

    e_h(2*nx-3,2*j) = (1.0/4.0)*(e_2h(nx-1,j) + e_2h(nx-1,j+1) + e_2h(nx,j) + e_2h(nx,j+1))

do j = 2,ny-2

    i = 1

        e_h(2*i,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + e_2h(i,j+1) + e_2h(i+1,j+1))
        e_h(2*i,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i+1,j) + 3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1))

    i = nx-1

        e_h(2*i-1,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + e_2h(i,j+1) + e_2h(i+1,j+1))
        e_h(2*i-1,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i+1,j) + 3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1))

end do

j = ny-1

    e_h(2,2*j-1) = (1.0/4.0)*(e_2h(1,j) + e_2h(1,j+1) + e_2h(2,j) + e_2h(2,j+1))

    do i = 2,nx-2

        e_h(2*i-1,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))
        e_h(2*i,2*j-1) = (1.0/8.0)*(e_2h(i,j) + e_2h(i,j+1) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i+1,j+1))

    end do

    e_h(2*nx-3,2*j-1) = (1.0/4.0)*(e_2h(nx-1,j) + e_2h(nx-1,j+1) + e_2h(nx,j) + e_2h(nx,j+1))

end subroutine


program mm

  integer, parameter :: k=5,m=6,n=4

  real, dimension(n,m) :: a = reshape( (/ (i, i=1, n*m) /), (/ n, m /) )
  real, dimension(m,k) :: b = reshape( (/ (i, i=1, m*k) /), (/ m, k /) )
  real, dimension(size(a,1), size(b,2)) :: c
  ! C is an array whose first dimension (row) size
  ! is the same as A's first dimension size, and
  ! whose second dimension (column) size is the same
  ! as B's second dimension size.

  ! c = matmul(a,b)
  c = a*b

  print *, 'A'
  do i = 1, n
     print *, a(i,:)
  end do

  print *,
  print *, 'B'
  do i = 1, m
     print *, b(i,:)
  end do

  print *,
  print *, 'C = AB'
  do i = 1, n
     print *, c(i,:)
  end do

end program mm


   subroutine hexcenter(ppitch, nrod, nrow, rodxy)
   implicit none
!=======================================================================
!
!  Subroutine to calculate rod centers in hexagon assembly
!
!  Orientation is so the "flats" are at the top and bottom
!
!=======================================================================
      integer, intent(in)  :: nrod    ! total number of rods
      integer, intent(in)  :: nrow    ! number of rows of rods
      real(8), intent(in)  :: ppitch  ! rod hex size flat to flat
      real(8), intent(out) :: rodxy(2,nrod)

      integer :: mm, ir, jj

      real(8) :: deltay

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

      write (*,*)
      write (*,*) 'calculating rod centers'

      rodxy(:,:)=0.0d0

      deltay=ppitch*sqrt(3.0d0)*0.5d0

      write(*,*) 'pin pitch ', ppitch
      write(*,*) 'nrod   ', nrod
      write(*,*) 'nrow   ', nrow

!  define central rod

      mm=1
      rodxy(1,mm)=0.0d0
      rodxy(2,mm)=0.0d0

!  Loop over rings to create cells
!   (it helps to look at a picture)

      do ir=1, nrow-1          ! row number, also number of rods on a "flat"

   ! new code that had "flats" on the top and bottom
   ! starting position is at the zero degree position, then work CC

        mm=mm+1                     ! starting location of "loop"
        rodxy(1,mm)=ppitch*dble(ir)
        rodxy(2,mm)=0.0d0

        do jj=1, ir     ! build up and to the left
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)-ppitch*0.5d0
          rodxy(2,mm)=rodxy(2,mm-1)+deltay
        enddo

        do jj=1, ir     ! build down and to left
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)-ppitch
          rodxy(2,mm)=rodxy(2,mm-1)
        enddo

        do jj=1, ir     ! build straight down
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)-ppitch*0.5d0
          rodxy(2,mm)=rodxy(2,mm-1)-deltay
        enddo

        do jj=1, ir     ! build down and to right
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)+ppitch*0.5d0
          rodxy(2,mm)=rodxy(2,mm-1)-deltay
        enddo

        do jj=1, ir     ! build up and to right
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)+ppitch
          rodxy(2,mm)=rodxy(2,mm-1)
        enddo

        do jj=1,ir-1   ! build straight up (don't clobber first hex)
          mm=mm+1
          rodxy(1,mm)=rodxy(1,mm-1)+ppitch*0.5d0
          rodxy(2,mm)=rodxy(2,mm-1)+deltay
        enddo

      enddo

      if (mm.ne.nrod) then
        write (*,*) 'nrod = ', nrod
        write (*,*) 'calculated nrod = ', mm
        stop 'nrod error in subroutine hexcenter'
      endif

      do mm=1, nrod
        if (abs(rodxy(1,mm)).lt.1.0d-10) rodxy(1,mm)=0.0d0  ! fix small roundoff
        if (abs(rodxy(2,mm)).lt.1.0d-10) rodxy(2,mm)=0.0d0  ! fix small roundoff
      enddo

      write (*,*)

      return
      end subroutine hexcenter

!=======================================================================
!
!  Subroutine to calculate rod centers in square assembly
!
!=======================================================================
      subroutine squarecenter(apitch, ppitch, nrod, nrow, rodxy)
      implicit none
      integer, intent(in)  :: nrod    ! total number of rods
      integer, intent(in)  :: nrow    ! number of rows of rods
      real(8), intent(in)  :: apitch  ! assembly pitch
      real(8), intent(in)  :: ppitch  ! pin pitch
      real(8), intent(out) :: rodxy(2,nrod)

      integer :: mm, i, j
      real(8) :: xc, yc
      real(8) :: gap2

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

      write (*,*)
      write (*,*) 'calculating rod centers in square assembly'

      rodxy(:,:)=0.0d0

!d    write(*,*) 'pin pitch ', ppitch
!d    write(*,*) 'nrod   ', nrod
!d    write(*,*) 'nrow   ', nrow

      if (nrod.ne.nrow*nrow) stop 'invalid nrod size in squarecenter'

!  zero is in lower left corner

      gap2=(apitch-nrow*ppitch)*0.5d0   ! half gap size
      if (abs(gap2).lt.0.00001d0) gap2=0.0d0   ! fix roundoff
      if (gap2.lt.0.0d0) stop 'invalid gap size'

      mm=0
      yc=gap2+ppitch*0.5d0
      do j=1, nrow
        xc=gap2+ppitch*0.5d0
        do i=1, nrow
           mm=mm+1
           rodxy(1,mm)=xc
           rodxy(2,mm)=yc
           xc=xc+ppitch
        enddo
        yc=yc+ppitch
      enddo

      return
      end subroutine squarecenter


program insertion
implicit none

!-----------------------------------------------------------------
! This programme sorts a series of values in increasing order,
! using insertion sort, implemented with one working array
!
! It works like this:
! unsorted: A = [5, 3, 4, 1, 2, 6]
! sorting:
! pass 1: B = [5, 3, 4, 1, 2, 6]
! pass 2: B = [2, 5, 3, 4, 1, 6]
! pass 3: B = [1, 2, 5, 3, 4, 6]
! pass 4: B = [1, 2, 4, 5, 3, 6]
! pass 5: B = [1, 2, 3, 4, 5, 6]
!------------------------------------------------------

real(kind=8), allocatable, dimension(:) :: A
real :: temp
integer :: i, j, k, n, element, sorted_sum
logical :: sorted

!------------------------------------------------------------
! Make some random array:
!------------------------------------------------------------

write(*,*) 'size od array?'
read(*,*) n
allocate (A(n))

call random_seed()
do i = 1, n
   call random_number(A(i))
   A(i) = (A(i) * 100.0)
   A(i) = real(nint(A(i)*1000)) / 1000.0 !rounding off to 3 decimal places
end do

!------------------------------------------------------------
! Prepare output file:
!------------------------------------------------------------

open(unit=1, file='insert', status='replace', action='write')
write(1,*) 'here you can see the details of how the loops and conditionals'
write(1,*) 'really work'

write(1,*)
write(1,*) '(using one array)'
write(1,*)
write(1,'(A3,10F7.3)') ' A ', A
write(*,'(A3,10F7.3)') ' A ', A
write(1,*)

!------------------------------------------------------------
! The actual sorting:
!------------------------------------------------------------

element=n !initialize array element
sorted_sum = 0 !initialize test for testing if the array is sorted
i = 0 !initialize counter
do while (sorted_sum .lt. n)
   i = i + 1
   write (1,*) 'pass:', i, 'array_position', element
   sorted = .false. !initalize test for array element
   do j = 1, element-1
      write(1,*) '   j', j
      if (A(j) .ge. A(element)) then
         write(1,*) 'found it'
         temp = A(element)
         do k = element-1, j, -1 !from the last value different from 0, to
!                                   the first one greater than i
            A(k+1) = A(k) !move every element by one
            write(1,*) '      k', k
         end do
         A(j) = temp
         sorted = .true.
         exit
      end if
   end do
   write(1,'(I4,10F7.3)') i, A
   write(1,*)
   write(*,'(I4,10F7.3)') i, A
   if (.not. sorted) element = element - 1
   sorted_sum = 1.0 !Because we will actually make n-1 comparisons
   do k = 1, n-1 ! Checking to see if the array has been sorted:
      if (A(k) .lt. A(k+1)) then
         sorted_sum = sorted_sum + 1
      end if
   end do
end do

end program insertion


!Autor: Claudio Iván Esparza Castañeda
!Título: Traza
!Descripción: Obtiene la traza de una matriz cuadrada
!Fecha: 16/04/2020

Program tra
  implicit none
  REAL, allocatable, dimension(:, :)::A, B
  INTEGER::N
  REAL::s
  INTEGER::i, j, k
  WRITE(*, *) "Dimensión de la matriz (número de filas igual al número de columnas)"
  READ(*, *) N
  allocate(A(1:N, 1:N))
  WRITE(*, *) "Elementos de la matriz:"
  do i=1, N
     do j=1, N
        READ(*, *) A(i, j)
     end do
  end do
  s=0
  do i=1, N
     do j=1, N
        if (i .eq. j) then
           s=s+A(i, j)
        end if
     end do
  end do
  WRITE(*, *) "Traza:"
  WRITE(*, *) s
  deallocate(A)
end Program tra


program newtont
  implicit real*8(a-h, o-z)
  external func, func1
  tol = 10.0D-6
  itr = 20
  x0 = 1
  n = 2
  call newton(x0, func, func1, n, x, itr, tol)
  write(*,*) x, m
  stop
end program newtont

function func(x,n)
  implicit real*8(a-h, o-z)
  func = x*x - n
  return
end function func

function func1(x)
  implicit real*8(a-h, o-z)
  func1 = 2*x
  return
end function func1

subroutine newton(x0, func, func1, n, x, m, itr, tol)
  implicit real*8(a-h, o-z)
  external func, func1
  m = 1
  do while (m <= itr)
     x = x0 -func(x0, n)/func1(x0)
     write(*,*) x, m
     if (DABS(x-x0) > tol) then
        x0 = x
        m = m + 1
     else
        return
     end if
  end do
  return
end subroutine newton


subroutine matrix_multiply(a,b,c,n)

real(8), dimension(n,n) :: a,b,c

! The following code is disabled for the moment.
! c=0.d0

do i = 1,n
  do j = 1,n
    do k = 1,n
      c(j,i) = c(j,i) + a(k,i) * b(j,k)
    enddo
 enddo
enddo

end subroutine matrix_multiply

! { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } }
! { dg-final { scan-tree-dump-times "will be loop blocked" 1 "graphite" { xfail *-*-* } } }


module uniform_interp

contains
 subroutine crop_indices(low,high, idx)
    ! crops indices to the borders of the image
    integer, intent(in) :: low, high
    real*8, intent(inout) :: idx
    if( idx < low) idx = dble(low)
    if( idx > high) idx = dble(high)
  end subroutine crop_indices

  real*8 function bilinear(x,y,z)
    ! Bilinear interpolation, input values x,y are
    ! expected in unitless decimal index value
    real*8, intent(in) :: x,y
    real*4, intent(in), dimension(:,:) :: z
    real*8 :: x1, x2, y1, y2
    real*8 :: q11, q12, q21, q22

    x1 = floor(x)
    x2 = ceiling(x)
    y1 = ceiling(y)
    y2 = floor(y)

    q11 = z(int(y1),int(x1))
    q12 = z(int(y2),int(x1))
    q21 = z(int(y1),int(x2))
    q22 = z(int(y2),int(x2))

    if(y1.eq.y2.and.x1.eq.x2) then
       bilinear = q11
    elseif(y1.eq.y2) then
       bilinear = (x2 - x)/(x2 - x1)*q11 + (x - x1)/(x2 - x1)*q21
    elseif (x1.eq.x2) then
       bilinear = (y2 - y)/(y2 - y1)*q11 + (y - y1)/(y2 - y1)*q12
    else
       bilinear = q11*(x2 - x)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
            q21*(x - x1)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
            q12*(x2 - x)*(y - y1)/((x2 - x1)*(y2 - y1)) + &
            q22*(x - x1)*(y - y1)/((x2 - x1)*(y2 - y1))
    end if
  end function bilinear

 complex function bilinear_cx(x,y,z)
      ! Bilinear interpolation, input values x,y are
      ! expected in unitless decimal index value
      real*8, intent(in) :: x,y
      complex, intent(in), dimension(:,:) :: z
      real*8 :: x1, x2, y1, y2
      complex :: q11, q12, q21, q22

      x1 = floor(x)
      x2 = ceiling(x)
      y1 = ceiling(y)
      y2 = floor(y)

      q11 = z(int(y1),int(x1))
      q12 = z(int(y2),int(x1))
      q21 = z(int(y1),int(x2))
      q22 = z(int(y2),int(x2))

      if(y1.eq.y2.and.x1.eq.x2) then
         bilinear_cx = q11
      elseif(y1.eq.y2) then
         bilinear_cx = (x2 - x)/(x2 - x1)*q11 + (x - x1)/(x2 - x1)*q21
      elseif (x1.eq.x2) then
         bilinear_cx = (y2 - y)/(y2 - y1)*q11 + (y - y1)/(y2 - y1)*q12
      else
         bilinear_cx = q11*(x2 - x)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
              q21*(x - x1)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
              q12*(x2 - x)*(y - y1)/((x2 - x1)*(y2 - y1)) + &
              q22*(x - x1)*(y - y1)/((x2 - x1)*(y2 - y1))
      end if
    end function bilinear_cx

     real*4 function bilinear_f(x,y,z)
      ! Bilinear interpolation, input values x,y are
      ! expected in unitless decimal index value
      real*8, intent(in) :: x,y
      real*4, intent(in), dimension(:,:) :: z
      real*8 :: x1, x2, y1, y2
      real*4 :: q11, q12, q21, q22

      x1 = floor(x)
      x2 = ceiling(x)
      y1 = ceiling(y)
      y2 = floor(y)

      q11 = z(int(y1),int(x1))
      q12 = z(int(y2),int(x1))
      q21 = z(int(y1),int(x2))
      q22 = z(int(y2),int(x2))

      if(y1.eq.y2.and.x1.eq.x2) then
         bilinear_f = q11
      elseif(y1.eq.y2) then
         bilinear_f = (x2 - x)/(x2 - x1)*q11 + (x - x1)/(x2 - x1)*q21
      elseif (x1.eq.x2) then
         bilinear_f = (y2 - y)/(y2 - y1)*q11 + (y - y1)/(y2 - y1)*q12
      else
         bilinear_f = q11*(x2 - x)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
              q21*(x - x1)*(y2 - y)/((x2 - x1)*(y2 - y1)) + &
              q12*(x2 - x)*(y - y1)/((x2 - x1)*(y2 - y1)) + &
              q22*(x - x1)*(y - y1)/((x2 - x1)*(y2 - y1))
      end if
    end function bilinear_f

  real*8 function bicubic(x,y,z)
    ! Bicubic interpolation, input values x,y are
    ! expected in unitless decimal index value
    ! (based on Numerical Recipes Algorithm)
    real*8, intent(in) :: x,y
    real*4, intent(in), dimension(:,:) :: z
    integer :: x1, x2, y1, y2, i, j, k, l
    real*8, dimension(4) :: dzdx,dzdy,dzdxy,zz
    real*8, dimension(4,4) :: c  ! coefftable
    real*8 :: q(16),qq,wt(16,16),cl(16),t,u
    save wt
    DATA wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,&
      10*0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,&
      4*0,1,0,-3,2,-2,0,6,-4,1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,&
      10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,-6,4,2*0,3,-2,&
      0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,&
      10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,&
      5*0,1,-2,1,0,-2,4,-2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,&
      10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,2,-2,2*0,-1,1/

    x1 = floor(x)
    x2 = ceiling(x)
!!$    y1 = ceiling(y)
!!$    y2 = floor(y)
    y1 = floor(y)
    y2 = ceiling(y)

    zz(1) = z(y1,x1)
    zz(4) = z(y2,x1)
    zz(2) = z(y1,x2)
    zz(3) = z(y2,x2)

    ! compute first order derivatives
    dzdx(1) = (z(y1,x1+1)-z(y1,x1-1))/2.d0
    dzdx(2) = (z(y1,x2+1)-z(y1,x2-1))/2.d0
    dzdx(3) = (z(y2,x2+1)-z(y2,x2-1))/2.d0
    dzdx(4) = (z(y2,x1+1)-z(y2,x1-1))/2.d0
    dzdy(1) = (z(y1+1,x1)-z(y1-1,x1))/2.d0
    dzdy(2) = (z(y1+1,x2+1)-z(y1-1,x2))/2.d0
    dzdy(3) = (z(y2+1,x2+1)-z(y2-1,x2))/2.d0
    dzdy(4) = (z(y2+1,x1+1)-z(y2-1,x1))/2.d0

    ! compute cross derivatives
    dzdxy(1) = 0.25d0*(z(y1+1,x1+1)-z(y1-1,x1+1)-&
         z(y1+1,x1-1)+z(y1-1,x1-1))
    dzdxy(4) = 0.25d0*(z(y2+1,x1+1)-z(y2-1,x1+1)-&
         z(y2+1,x1-1)+z(y2-1,x1-1))
    dzdxy(2) = 0.25d0*(z(y1+1,x2+1)-z(y1-1,x2+1)-&
         z(y1+1,x2-1)+z(y1-1,x2-1))
    dzdxy(3) = 0.25d0*(z(y2+1,x2+1)-z(y2-1,x2+1)-&
         z(y2+1,x2-1)+z(y2-1,x2-1))

    ! compute polynomial coeff
    ! pack values into temp array qq
    do i = 1,4
       q(i) = zz(i)
       q(i+4) = dzdx(i)
       q(i+8) = dzdy(i)
       q(i+12) = dzdxy(i)
    enddo
    ! matrix multiply by the stored table
    do i = 1,16
       qq = 0.d0
       do k = 1,16
          qq = qq+wt(i,k)*q(k)
       enddo
       cl(i)=qq
    enddo

    ! unpack results into the coeff table
    l = 0
    do i = 1,4
       do j = 1,4
          l = l + 1
          c(i,j) = cl(l)
       enddo
    enddo

    ! normalize desired points from 0to1
    t = (x - x1)
    u = (y - y1)
    bicubic = 0.d0
    do i=4,1,-1
       bicubic = t*bicubic+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
    enddo

  end function bicubic

  complex function bicubic_cx(x,y,z)
    ! Bicubic interpolation, input values x,y are
    ! expected in unitless decimal index value
    ! (based on Numerical Recipes Algorithm)
    real*8, intent(in) :: x,y
    complex, intent(in), dimension(:,:) :: z
    integer :: x1, x2, y1, y2, i, j, k, l
    complex, dimension(4) :: dzdx,dzdy,dzdxy,zz
    complex, dimension(4,4) :: c  ! coefftable
    complex :: q(16),qq,cl(16)
    real*8 :: wt(16,16),t,u
    save wt
    DATA wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,&
      10*0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,&
      4*0,1,0,-3,2,-2,0,6,-4,1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,&
      10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0,-6,4,2*0,3,-2,&
      0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2,&
      10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,&
      5*0,1,-2,1,0,-2,4,-2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,&
      10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0,2,-2,2*0,-1,1/

    x1 = floor(x)
    x2 = ceiling(x)
!!$    y1 = ceiling(y)
!!$    y2 = floor(y)
    y1 = floor(y)
    y2 = ceiling(y)

    zz(1) = z(y1,x1)
    zz(4) = z(y2,x1)
    zz(2) = z(y1,x2)
    zz(3) = z(y2,x2)

    ! compute first order derivatives
    dzdx(1) = (z(y1,x1+1)-z(y1,x1-1))/2.d0
    dzdx(2) = (z(y1,x2+1)-z(y1,x2-1))/2.d0
    dzdx(3) = (z(y2,x2+1)-z(y2,x2-1))/2.d0
    dzdx(4) = (z(y2,x1+1)-z(y2,x1-1))/2.d0
    dzdy(1) = (z(y1+1,x1)-z(y1-1,x1))/2.d0
    dzdy(2) = (z(y1+1,x2+1)-z(y1-1,x2))/2.d0
    dzdy(3) = (z(y2+1,x2+1)-z(y2-1,x2))/2.d0
    dzdy(4) = (z(y2+1,x1+1)-z(y2-1,x1))/2.d0

    ! compute cross derivatives
    dzdxy(1) = 0.25d0*(z(y1+1,x1+1)-z(y1-1,x1+1)-&
         z(y1+1,x1-1)+z(y1-1,x1-1))
    dzdxy(4) = 0.25d0*(z(y2+1,x1+1)-z(y2-1,x1+1)-&
         z(y2+1,x1-1)+z(y2-1,x1-1))
    dzdxy(2) = 0.25d0*(z(y1+1,x2+1)-z(y1-1,x2+1)-&
         z(y1+1,x2-1)+z(y1-1,x2-1))
    dzdxy(3) = 0.25d0*(z(y2+1,x2+1)-z(y2-1,x2+1)-&
         z(y2+1,x2-1)+z(y2-1,x2-1))

    ! compute polynomial coeff
    ! pack values into temp array qq
    do i = 1,4
       q(i) = zz(i)
       q(i+4) = dzdx(i)
       q(i+8) = dzdy(i)
       q(i+12) = dzdxy(i)
    enddo
    ! matrix multiply by the stored table
    do i = 1,16
       qq = 0.d0
       do k = 1,16
          qq = qq+wt(i,k)*q(k)
       enddo
       cl(i)=qq
    enddo

    ! unpack results into the coeff table
    l = 0
    do i = 1,4
       do j = 1,4
          l = l + 1
          c(i,j) = cl(l)
       enddo
    enddo

    ! normalize desired points from 0to1
    t = (x - x1)
    u = (y - y1)
    bicubic_cx = 0.d0
    do i=4,1,-1
       bicubic_cx = t*bicubic_cx+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1)
    enddo

  end function bicubic_cx

!!$c****************************************************************

      subroutine sinc_coef(r_beta,r_relfiltlen,i_decfactor,r_pedestal,&
          i_weight,i_intplength,i_filtercoef,r_filter)

!!$c****************************************************************
!!$c**
!!$c**   FILE NAME: sinc_coef.f
!!$c**
!!$c**   DATE WRITTEN: 10/15/97
!!$c**
!!$c**   PROGRAMMER: Scott Hensley
!!$c**
!!$c**   FUNCTIONAL DESCRIPTION: The number of data values in the array
!!$c**   will always be the interpolation length * the decimation factor,
!!$c**   so this is not returned separately by the function.
!!$c**
!!$c**   ROUTINES CALLED:
!!$c**
!!$c**   NOTES:
!!$c**
!!$c**   UPDATE LOG:
!!$c**
!!$c**   Date Changed        Reason Changed                  CR # and Version #
!!$c**   ------------       ----------------                 -----------------
!!$c**   06/18/21           adjust r_soff to make sure coef at the center is 1.
!!$c**                      note that the routine doesn't work well for odd sequences
!!$c*****************************************************************

      use fortranUtils

      implicit none

!c     INPUT VARIABLES:

      real*8 r_beta             !the "beta" for the filter
      real*8 r_relfiltlen       !relative filter length
      integer i_decfactor       !the decimation factor
      real*8 r_pedestal         !pedestal height
      integer i_weight          !0 = no weight , 1=weight

!c     OUTPUT VARIABLES:

      integer i_intplength      !the interpolation length
      integer i_filtercoef      !number of coefficients
      real*8 r_filter(*)        !an array of data values

!c     LOCAL VARIABLES:

      real*8 r_wgt,r_s,r_fct,r_wgthgt,r_soff,r_wa
      integer i
      real*8 pi,j

!c     COMMON BLOCKS:

!c     EQUIVALENCE STATEMENTS:

!c     DATA STATEMENTS:

!C     FUNCTION STATEMENTS:

!c     PROCESSING STEPS:

!c     number of coefficients

      pi = getPi()

      i_intplength = nint(r_relfiltlen/r_beta)
      i_filtercoef = i_intplength*i_decfactor
      r_wgthgt = (1.d0 - r_pedestal)/2.d0
      r_soff = i_filtercoef/2.d0

      do i=0,i_filtercoef-1
         r_wa = i - r_soff
         r_s = r_wa*r_beta/(1.0d0 * i_decfactor)
         if(r_s .ne. 0.0)then
            r_fct = sin(pi*r_s)/(pi*r_s)
         else
            r_fct = 1.0d0
         endif
         if(i_weight .eq. 1)then
            r_wgt = (1.d0 - r_wgthgt) + r_wgthgt*cos((pi*r_wa)/r_soff)
            r_filter(i+1) = r_fct*r_wgt
         else
            r_filter(i+1) = r_fct
         endif

!!         print *, i, r_wa, r_wgt,j,r_s,r_fct
      enddo

    end subroutine sinc_coef

!cc-------------------------------------------

      complex*8 function sinc_eval(arrin,nsamp,intarr,idec,ilen,intp,frp)

      integer ilen,idec,intp, nsamp
      real*8 frp
      complex arrin(0:nsamp-1)
      real*4 intarr(0:idec*ilen-1)

! note: arrin is a zero based coming in, so intp must be a zero-based index.

      sinc_eval = cmplx(0.,0.)
      if(intp .ge. ilen-1 .and. intp .lt. nsamp ) then
         ifrac= min(max(0,int(frp*idec)),idec-1)
         do k=0,ilen-1
            sinc_eval = sinc_eval + arrin(intp-k)*intarr(k + ifrac*ilen)
         enddo
      end if

      end function sinc_eval

    real*4 function sinc_eval_2d_f(arrin,intarr,idec,ilen,intpx,intpy,frpx,frpy,xlen,ylen)

      integer ilen,idec,intpx,intpy,xlen,ylen,k,m,ifracx,ifracy
      real*8 frpx,frpy
      real*4 arrin(0:xlen-1,0:ylen-1)
      real*4 intarr(0:idec*ilen-1)

! note: arrin is a zero based coming in, so intp must be a zero-based index.

      sinc_eval_2d_f = 0.
      if((intpx.ge.ilen-1.and.intpx.lt.xlen) .and. (intpy.ge.ilen-1.and.intpy.lt.ylen)) then

        ifracx= min(max(0,int(frpx*idec)),idec-1)
        ifracy= min(max(0,int(frpy*idec)),idec-1)

        do k=0,ilen-1
           do m=0,ilen-1
              sinc_eval_2d_f = sinc_eval_2d_f + arrin(intpx-k,intpy-m)*&
                   intarr(k + ifracx*ilen)*intarr(m + ifracy*ilen)
           enddo
        enddo

      end if
    end function sinc_eval_2d_f

    real*4 function sinc_eval_2d_d(arrin,intarr,idec,ilen,intpx,intpy,frpx,frpy,xlen,ylen)

      integer ilen,idec,intpx,intpy,xlen,ylen,k,m,ifracx,ifracy
      real*8 frpx,frpy
      real*8 arrin(0:xlen-1,0:ylen-1)
      real*8 intarr(0:idec*ilen-1)

! note: arrin is a zero based coming in, so intp must be a zero-based index.

      sinc_eval_2d_d = 0.d0
      if((intpx.ge.ilen-1.and.intpx.lt.xlen) .and. (intpy.ge.ilen-1.and.intpy.lt.ylen)) then

        ifracx= min(max(0,int(frpx*idec)),idec-1)
        ifracy= min(max(0,int(frpy*idec)),idec-1)

        do k=0,ilen-1
           do m=0,ilen-1
              sinc_eval_2d_d = sinc_eval_2d_d + arrin(intpx-k,intpy-m)*&
                   intarr(k + ifracx*ilen)*intarr(m + ifracy*ilen)
           enddo
        enddo
      end if
    end function sinc_eval_2d_d

    complex function sinc_eval_2d_cx(arrin,intarr,idec,ilen,intpx,intpy,frpx,frpy,xlen,ylen)

      integer ilen,idec,intpx,intpy,xlen,ylen,k,m,ifracx,ifracy
      real*8 frpx,frpy, fweight, fweightsum
      complex arrin(0:xlen-1,0:ylen-1)
      real*4 intarr(0:idec*ilen-1)

! note: arrin is a zero based coming in, so intp must be a zero-based index.

      sinc_eval_2d_cx = cmplx(0.,0.)
      if((intpx.ge.ilen-1.and.intpx.lt.xlen) .and. (intpy.ge.ilen-1.and.intpy.lt.ylen)) then

        ifracx= min(max(0,int(frpx*idec)),idec-1)
        ifracy= min(max(0,int(frpy*idec)),idec-1)

        ! to normalize the sinc interpolator
        fweightsum = 0.

        do k=0,ilen-1
           do m=0,ilen-1
              fweight = intarr(k + ifracx*ilen)*intarr(m + ifracy*ilen)
              sinc_eval_2d_cx = sinc_eval_2d_cx + arrin(intpx-k,intpy-m) * fweight
              fweightsum = fweightsum + fweight
           enddo
        enddo
        sinc_eval_2d_cx = sinc_eval_2d_cx/fweightsum
      end if

    end function sinc_eval_2d_cx

end module uniform_interp


!
!...Get the shape functions for an curved edge
!
subroutine getshapfct_edge(ncurv,nvfac,shpf, dshprf, r)
implicit none
integer,                   intent(in)::ncurv,nvfac
real*8, dimension(nvfac), intent(out):: shpf
real*8, dimension(nvfac), intent(out):: dshprf
real*8,                    intent(in):: r
!
if(ncurv.eq.0)then
!...Shape functions
shpf(1) =  (1.d0-r)/2.d0
shpf(2) =  (1.d0+r)/2.d0

dshprf(1) =-.5d0
dshprf(2) = .5d0

!...Quadratic cell
elseif(ncurv.eq.1)then
shpf(1) =  -0.5d0*(1.d0-r)*r
shpf(2) =   0.5d0*(1.d0+r)*r
shpf(3) =         (1.d0+r)*(1.d0-r)
!
dshprf(1) = -0.5d0 + r
dshprf(2) =  0.5d0 + r
dshprf(3) = -2.d0*r

!...Cubic cell
elseif(ncurv.eq.2)then
!...Shape functions
shpf(1) =  9.d0/16.d0*(1.d0-r)*(r+1.d0/3.d0)*(r-1.d0/3.d0)
shpf(2) = -9.d0/16.d0*(1.d0+r)*(1.d0/3.d0-r)*(r+1.d0/3.d0)
shpf(3) =  27.d0/16.d0*(r-1.d0)*(r+1.d0)*(r-1.d0/3.d0)
shpf(4) = -27.d0/16.d0*(r-1.d0)*(r+1.d0)*(r+1.d0/3.d0)
!
dshprf(1) = 9.d0/16.d0*(1.d0/9.d0-3.d0*r**2+2.d0*r)
dshprf(2) =-9.d0/16.d0*(1.d0/9.d0-3.d0*r**2-2.d0*r)
dshprf(3) = 27.d0/16.d0*(-1.d0+3.d0*r**2-2.d0/3.d0*r)
dshprf(4) =-27.d0/16.d0*(-1.d0+3.d0*r**2+2.d0/3.d0*r)
!
endif

end subroutine getshapfct_edge
!
!...Get the shape functions for an curved cell
!
subroutine getshapfct_quad(ncurv,nvqua,shpq, dshprq, dshpsq, r, s)
implicit none
integer,                   intent(in)::ncurv,nvqua
real*8, dimension(nvqua), intent(out):: shpq
real*8, dimension(nvqua), intent(out):: dshprq, dshpsq
real*8,                    intent(in):: r, s
!
!...Local array
real*8,dimension(2, nvqua) ::xrq
integer,dimension(1:nvqua) ::idmpp
!
real*8::rsp,ssp
real*8::rp,rm,sp,sm
integer::ishp

real*8::c10
!
c10 =1.d0

!...Qudratic cell
if(ncurv.eq.0)then
!
rp = c10 + r
rm = c10 - r
sp = c10 + s
sm = c10 - s
!...  shape function & its derivatives w.r.t. reference coordinates
shpq(1) = 0.25d0*rm*sm
shpq(2) = 0.25d0*rp*sm
shpq(3) = 0.25d0*rp*sp
shpq(4) = 0.25d0*rm*sp
!
dshprq(1) = -0.25d0   *sm
dshprq(2) =  0.25d0   *sm
dshprq(3) =  0.25d0   *sp
dshprq(4) = -0.25d0   *sp
!
dshpsq(1) =-0.25d0*rm
dshpsq(2) =-0.25d0*rp
dshpsq(3) = 0.25d0*rp
dshpsq(4) = 0.25d0*rm
elseif(ncurv.eq.1)then
!...  shape function & its derivatives w.r.t. reference coordinates
shpq(1) = 0.25d0*(c10-r)*r*s*(c10-s)
shpq(2) =-0.25d0*(c10+r)*(c10-s)*r*s
shpq(3) = 0.25d0*(c10+r)*(c10+s)*r*s
shpq(4) =-0.25d0*(c10-r)*(c10+s)*r*s
shpq(5) =-0.5d0*(c10-r**2)*(c10-s)*s
shpq(6) = 0.5d0*(c10+r)*(c10-s**2)*r
shpq(7) = 0.5d0*(c10-r**2)*(c10+s)*s
shpq(8) = -0.5d0*(c10-r)*(c10-s**2)*r
shpq(9) = (c10-r**2)*(c10-s**2)
!
dshprq(1) = 0.25d0*(2.d0*r-c10)*s*(s-1.d0)
dshprq(2) = 0.25d0*(2.d0*r+c10)*s*(s-1.d0)
dshprq(3) = 0.25d0*(2.d0*r+c10)*s*(s+1.d0)
dshprq(4) = 0.25d0*(2.d0*r-c10)*s*(s+1.d0)
dshprq(5) =   -r*s*(s-c10)
dshprq(6) =  0.5d0*(2.d0*r+c10)*(c10-s*s)
dshprq(7) =   -r*s*(s+c10)
dshprq(8) = 0.5d0*(2.d0*r-c10)*(1.d0-s*s)
dshprq(9) = -2.0d0*r*(1.d0-s*s)
!
dshpsq(1) = 0.25d0*(2.d0*s-c10)*r*(r-1.d0)
dshpsq(2) = 0.25d0*(2.d0*s-c10)*r*(r+1.d0)
dshpsq(3) = 0.25d0*(2.d0*s+c10)*r*(r+1.d0)
dshpsq(4) = 0.25d0*(2.d0*s+c10)*r*(r-1.d0)
dshpsq(5) =  0.5d0*(1.d0-r*r)*(2.d0*s-c10)
dshpsq(6) =   -r*s*(r+c10)
dshpsq(7) =  0.5d0*(1.d0-r*r)*(2.d0*s+c10)
dshpsq(8) = -r*s*(r-c10)
dshpsq(9) = -2.0d0*s*(1.d0-r*r)

!...Cubic cell
elseif(ncurv.eq.2)then
!...Mapping array
idmpp(1:4) =  (/1,2,3,4/)
idmpp(5:8) =  (/5,9,7,11/)
idmpp(9:12) = (/6,10,8,12/)

!...Reference coordinates
xrq(1, 1) = -1.d0; xrq(2, 1) = -1.d0;
xrq(1, 2) =  1.d0; xrq(2, 2) = -1.d0;
xrq(1, 3) =  1.d0; xrq(2, 3) =  1.d0;
xrq(1, 4) = -1.d0; xrq(2, 4) =  1.d0;
xrq(1, 5) = -1.d0/3.d0; xrq(2, 5) = -1.d0;
xrq(1, 6) =  1.d0;      xrq(2, 6) = -1.d0/3.d0;
xrq(1, 7) =  1.d0/3.d0; xrq(2, 7) =  1.d0;
xrq(1, 8) = -1.d0;      xrq(2, 8) =  1.d0/3.d0;
xrq(1, 9) =  1.d0/3.d0; xrq(2, 9) = -1.d0;
xrq(1,10) =  1.d0;      xrq(2,10) =  1.d0/3.d0;
xrq(1,11) = -1.d0/3.d0; xrq(2,11) =  1.d0;
xrq(1,12) = -1.d0;      xrq(2,12) = -1.d0/3.d0;

!...Shape functions

!...Corner nodes
do ishp =1,4
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
shpq(idmpp(ishp)) = 1.d0/32.d0*(1.d0+r*rsp)*(1.d0+s*ssp)*&
(9.d0*(r**2+s**2)-10.d0)
enddo

!...Edge nodes
do ishp =5, 8
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
shpq(idmpp(ishp)) = 9.d0/32.d0*(1.d0+s*ssp)*(1.d0-r**2)*&
(9.d0*r*rsp+1.d0)
enddo

!...Edge nodes
do ishp =9 ,12
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
shpq(idmpp(ishp)) = 9.d0/32.d0*(1.d0+r*rsp)*(1.d0-s**2)*&
(9.d0*s*ssp+1.d0)
enddo

!...Derivative for shape functions

!...Corner nodes
do ishp =1,4
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
dshprq(idmpp(ishp)) = 1.d0/32.d0*(1.d0+s*ssp)*&
(27.d0*rsp*r**2+9.d0*rsp*s**2-10.d0*rsp+18.d0*r)
dshpsq(idmpp(ishp)) = 1.d0/32.d0*(1.d0+r*rsp)*&
(27.d0*ssp*s**2+9.d0*ssp*r**2-10.d0*ssp+18.d0*s)
enddo

!...Edge nodes
do ishp =5,8
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
dshprq(idmpp(ishp)) = 9.d0/32.d0*(1.d0+s*ssp)*&
(-27.d0*r**2*rsp-2.d0*r+9.d0*rsp)
dshpsq(idmpp(ishp)) = 9.d0/32.d0*ssp*(1.d0-r**2)*&
(9.d0*r*rsp+1.d0)

enddo

!...Edge nodes
do ishp =9,12
rsp = xrq(1, idmpp(ishp))
ssp = xrq(2, idmpp(ishp))
dshprq(idmpp(ishp)) = 9.d0/32.d0*rsp*(1.d0-s**2)*&
(9.d0*s*ssp+1.d0)
dshpsq(idmpp(ishp)) = 9.d0/32.d0*(1.d0+r*rsp)*&
(-27.d0*s**2*ssp-2.d0*s+9.d0*ssp)
enddo

!
endif

end subroutine getshapfct_quad