      SUBROUTINE POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,
     1                   MDIMF,F,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C     SUBROUTINE POIS3D SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C       C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K))
C     + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K))
C     + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K)
C
C     FOR  I=1,2,...,L , J=1,2,...,M , AND K=1,2,...,N .
C
C     THE INDICES K-1 AND K+1 ARE EVALUATED MODULO N, I.E.
C     X(I,J,0) = X(I,J,N) AND X(I,J,N+1) = X(I,J,1). THE UNKNOWNS
C     X(0,J,K), X(L+1,J,K), X(I,0,K), AND X(I,M+1,K) ARE ASSUMED TO TAKE
C     ON CERTAIN PRESCRIBED VALUES DESCRIBED BELOW.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C
C            * * * * * *   ON INPUT    * * * * * *
C
C     LPEROD   INDICATES THE VALUES THAT X(0,J,K) AND X(L+1,J,K) ARE
C              ASSUMED TO HAVE.
C
C              = 0  IF X(0,J,K) = X(L,J,K) AND X(L+1,J,K) = X(1,J,K).
C              = 1  IF X(0,J,K) = X(L+1,J,K) = 0.
C              = 2  IF X(0,J,K) = 0  AND X(L+1,J,K) = X(L-1,J,K).
C              = 3  IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = X(L-1,J,K).
C              = 4  IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = 0.
C
C     L        THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. L MUST BE AT
C              LEAST 3.
C
C     C1       THE REAL CONSTANT THAT APPEARS IN THE ABOVE EQUATION.
C
C     MPEROD   INDICATES THE VALUES THAT X(I,0,K) AND X(I,M+1,K) ARE
C              ASSUMED TO HAVE.
C
C              = 0  IF X(I,0,K) = X(I,M,K) AND X(I,M+1,K) = X(I,1,K).
C              = 1  IF X(I,0,K) = X(I,M+1,K) = 0.
C              = 2  IF X(I,0,K) = 0 AND X(I,M+1,K) = X(I,M-1,K).
C              = 3  IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = X(I,M-1,K).
C              = 4  IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = 0.
C
C     M        THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. M MUST BE AT
C              LEAST 3.
C
C     C2       THE REAL CONSTANT WHICH APPEARS IN THE ABOVE EQUATION.
C
C     NPEROD   = 0  IF A(1) AND C(N) ARE NOT ZERO.
C              = 1  IF A(1) = C(N) = 0.
C
C     N        THE NUMBER OF UNKNOWNS IN THE K-DIRECTION. N MUST BE AT
C              LEAST 3.
C
C
C     A,B,C    ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE
C              COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C              IF NPEROD = 0 THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE
C              INDEX K, BUT MUST BE CONSTANT.  SPECIFICALLY,THE
C              SUBROUTINE CHECKS THE FOLLOWING CONDITION
C
C                          A(K) = C(1)
C                          C(K) = C(1)
C                          B(K) = B(1)
C
C                  FOR K=1,2,...,N.
C
C     LDIMF    THE ROW (OR FIRST) DIMENSION OF THE THREE-DIMENSIONAL
C              ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D.
C              THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION
C              OF F.  LDIMF MUST BE AT LEAST L.
C
C     MDIMF    THE COLUMN (OR SECOND) DIMENSION OF THE THREE-DIMENSIONAL
C              ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D.
C              THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION
C              OF F.  MDIMF MUST BE AT LEAST M.
C
C     F        A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF
C              THE RIGHT SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN
C              ABOVE.  F MUST BE DIMENSIONED AT LEAST L X M X N.
C
C     W        A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE
C              USER FOR WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST
C              30 + L + M + 2*N + MAX(L,M,N) +
C              7*(INT((L+1)/2) + INT((M+1)/2)).
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C     F        CONTAINS THE SOLUTION X.
C
C     IERROR   AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C              EXCEPT FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C              = 0  NO ERROR
C              = 1  IF LPEROD .LT. 0 OR .GT. 4
C              = 2  IF L .LT. 3
C              = 3  IF MPEROD .LT. 0 OR .GT. 4
C              = 4  IF M .LT. 3
C              = 5  IF NPEROD .LT. 0 OR .GT. 1
C              = 6  IF N .LT. 3
C              = 7  IF LDIMF .LT. L
C              = 8  IF MDIMF .LT. M
C              = 9  IF A(K) .NE. C(1) OR C(K) .NE. C(1) OR B(I) .NE.B(1)
C                      FOR SOME K=1,2,...,N.
C              = 10 IF NPEROD = 1 AND A(1) .NE. 0 OR C(N) .NE. 0
C
C              SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C              INCORRECT CALL TO POIS3D, THE USER SHOULD TEST IERROR
C              AFTER THE CALL.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   A(N),B(N),C(N),F(LDIMF,MDIMF,N),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         DECEMBER 1, 1978
C     REVISION
C
C     SUBPROGRAMS    POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,RFFTB,
C     REQUIRED       RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1
C                    COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1,
C                    CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF,
C                    CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH,
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977
C
C     ALGORITHM      THIS SUBROUTINE SOLVES THREE-DIMENSIONAL BLOCK
C                    TRIDIAGONAL LINEAR SYSTEMS ARISING FROM FINITE
C                    DIFFERENCE APPROXIMATIONS TO THREE-DIMENSIONAL
C                    POISSON EQUATIONS USING THE FOURIER TRANSFORM
C                    PACKAGE SCLRFFTPAK WRITTEN BY PAUL SWARZTRAUBER.
C
C     SPACE          6561(DECIMAL) = 14641(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE POIS3D IS ROUGHLY PROPORTIONAL
C                    TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON
C                    INPUT PARAMETERS LPEROD AND MPEROD.  SOME TYPICAL
C                    VALUES ARE LISTED IN THE TABLE BELOW WHEN NPEROD=0.
C                       TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                    UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE
C                    A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE
C                    'PURPOSE' WITH
C
C                       A(K) = C(K) = -0.5*B(K) = 1,       K=1,2,...,N
C
C                    AND, WHEN NPEROD = 1
C
C                       A(1) = C(N) = 0
C                       A(N) = C(1) = 2.
C
C                    THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS-
C                    TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS
C                    COMPUTED.  USING THIS ARRAY Y SUBROUTINE POIS WAS
C                    CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z.  THEN
C                    THE RELATIVE ERROR, DEFINED AS
C
C                    E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K)))
C
C                    WHERE THE TWO MAXIMA ARE TAKEN OVER I=1,2,...,L,
C                    J=1,2,...,M AND K=1,2,...,N, WAS COMPUTED.  THE
C                    VALUE OF E IS GIVEN IN THE TABLE BELOW FOR SOME
C                    TYPICAL VALUES OF L,M AND N.
C
C
C                       L(=M=N)   LPEROD    MPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         16        0         0         272     1.E-13
C                         15        1         1         287     4.E-13
C                         17        3         3         338     2.E-13
C                         32        0         0        1755     2.E-13
C                         31        1         1        1894     2.E-12
C                         33        3         3        2042     7.E-13
C
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,
     1                F(LDIMF,MDIMF,1)       ,W(1)       ,SAVE(6)
      LP = LPEROD+1
      MP = MPEROD+1
      NP = NPEROD+1
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
      IF (L .LT. 3) IERROR = 2
      IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
      IF (M .LT. 3) IERROR = 4
      IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
      IF (N .LT. 3) IERROR = 6
      IF (LDIMF .LT. L) IERROR = 7
      IF (MDIMF .LT. M) IERROR = 8
      IF (NP .NE. 1) GO TO 103
      DO 101 K=1,N
         IF (A(K) .NE. C(1)) GO TO 102
         IF (C(K) .NE. C(1)) GO TO 102
         IF (B(K) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 9
  103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
  104 IF (IERROR .NE. 0) GO TO 122
      IWYRT = L+1
      IWT = IWYRT+M
      IWD = IWT+MAX0(L,M,N)+1
      IWBB = IWD+N
      IWX = IWBB+N
      IWY = IWX+7*((L+1)/2)+15
      GO TO (105,114),NP
C
C     REORDER UNKNOWNS WHEN NPEROD = 0.
C
  105 NH = (N+1)/2
      NHM1 = NH-1
      NODD = 1
      IF (2*NH .EQ. N) NODD = 2
      DO 111 I=1,L
         DO 110 J=1,M
            DO 106 K=1,NHM1
               NHPK = NH+K
               NHMK = NH-K
               W(K) = F(I,J,NHMK)-F(I,J,NHPK)
               W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
  106       CONTINUE
            W(NH) = 2.*F(I,J,NH)
            GO TO (108,107),NODD
  107       W(N) = 2.*F(I,J,N)
  108       DO 109 K=1,N
               F(I,J,K) = W(K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      SAVE(1) = C(NHM1)
      SAVE(2) = A(NH)
      SAVE(3) = C(NH)
      SAVE(4) = B(NHM1)
      SAVE(5) = B(N)
      SAVE(6) = A(N)
      C(NHM1) = 0.
      A(NH) = 0.
      C(NH) = 2.*C(NH)
      GO TO (112,113),NODD
  112 B(NHM1) = B(NHM1)-A(NH-1)
      B(N) = B(N)+A(N)
      GO TO 114
  113 A(N) = C(NH)
  114 CONTINUE
      CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
     1             W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
      GO TO (115,122),NP
  115 DO 121 I=1,L
         DO 120 J=1,M
            DO 116 K=1,NHM1
               NHMK = NH-K
               NHPK = NH+K
               W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
               W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
  116       CONTINUE
            W(NH) = .5*F(I,J,NH)
            GO TO (118,117),NODD
  117       W(N) = .5*F(I,J,N)
  118       DO 119 K=1,N
               F(I,J,K) = W(K)
  119       CONTINUE
  120    CONTINUE
  121 CONTINUE
      C(NHM1) = SAVE(1)
      A(NH) = SAVE(2)
      C(NH) = SAVE(3)
      B(NHM1) = SAVE(4)
      B(N) = SAVE(5)
      A(N) = SAVE(6)
  122 CONTINUE
      RETURN
      END


*     MB02CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX
      PARAMETER        ( KMAX = 20, NMAX = 20 )
      INTEGER          LCS, LDG, LDL, LDR, LDT, LDWORK
      PARAMETER        ( LDG = 2*KMAX, LDL = NMAX*KMAX, LDR = NMAX*KMAX,
     $                   LDT = KMAX, LDWORK = ( NMAX - 1 )*KMAX )
      PARAMETER        ( LCS = 3*LDWORK )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N
      CHARACTER        JOB, TYPET
*     .. Local Arrays .. (Dimensioned for TYPET = 'R'.)
      DOUBLE PRECISION CS(LCS), DWORK(LDWORK), G(LDG, NMAX*KMAX),
     $                 L(LDL, NMAX*KMAX), R(LDR, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLASET, MB02CD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, JOB
      TYPET = 'R'
      M = N*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         IF( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99992 ) K
         ELSE
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
*           Compute the Cholesky factor(s) and/or the generator.
            CALL MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L,
     $                   LDL, CS, LCS, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF ( LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'A' ) .OR.
     $              LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'R' ) ) THEN
                  WRITE ( NOUT, FMT = 99997 )
                  CALL DLASET( 'Full', K, K, ZERO, ZERO, G(K+1,1), LDG )
                  DO 10  I = 1, 2*K
                     WRITE ( NOUT, FMT = 99994 ) ( G(I,J), J = 1, M )
   10             CONTINUE
               END IF
               IF ( LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) ) THEN
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20  I = 1, M
                     WRITE ( NOUT, FMT = 99994 ) ( L(I,J), J = 1, M )
   20             CONTINUE
               END IF
               IF ( LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' )
     $                                .OR. LSAME( JOB, 'O' ) ) THEN
                  WRITE ( NOUT, FMT = 99995 )
                  DO 30  I = 1, M
                     WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M )
   30             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02CD = ',I2)
99997 FORMAT (' The generator of the inverse of block Toeplitz matrix',
     $        ' is ')
99996 FORMAT (/' The lower Cholesky factor of the inverse is ')
99995 FORMAT (/' The upper Cholesky factor of block Toeplitz matrix is '
     $       )
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' K is out of range.',/' K = ',I5)
      END


PROGRAM lat_id_driver
    use sp_hnfs
    use rational_mathematics, only: SmithNormalForm
    use num_types

    implicit none

    integer :: n, at(1), n_irr, nhnfs, i, err, j,k
    integer :: r_low, r_high
    CHARACTER(len=32) :: arg1,arg2
    integer, allocatable :: HNFs(:,:,:)
    real(dp), pointer :: B_vecs(:,:)
    integer :: Co(3,3), Cu(3,3), S(3,3), L(3,3), R(3,3)
    real(dp) :: No(3,3), Nu(3,3), O(3,3), U(3,3), offsets(1,3)
    real(dp) :: grid(3,3), best_offset(3)
    logical :: all_hnfs
    !Get command line args
    call getarg(1,arg1)
    call getarg(2,arg2)
    read(arg1,*) r_low
    read(arg2,*) r_high

    ! This is just some basic setup stuff which you should never chance
    ! since it's not effecting the code at all but it has to be here for
    ! the code to run.
    Co = 0; Cu = 0; No = 0.0_dp; Nu = 0.0_dp; O = 0.0_dp; U = 0.0_dp; offsets = 0.0_dp;
    at = 1
    all_hnfs = .True.
    allocate(B_vecs(3,1))
    B_vecs = 0.0_dp
    do i=1,3
    Co(i,i) = 1; Cu(i,i) = 1
    No(i,i) = 1.0_dp; O(i,i) = 1.0_dp; Nu(i,i) = 1.0_dp; U(i,i) = 1.0_dp
    end do
    k=0
    ! Change the upper and lower limits on this to whatever you want.
    do n = r_low,r_high
    print *, "Running HNFs of determinant: ", n
    ! Change this function call to whichever case from sp_hnfs you want.
    if(Mod(n,1000) == 0) then
        print *, "Running HNFs of determinant: ", n
    endif
    call hex_12(n, No, Nu, Co, Cu, O, U, B_vecs, at, offsets, best_offset, HNFs, grid, &
        n_irr, nhnfs, all_hnfs_=all_hnfs)
    print *, "nhnfs", nhnfs
    if (nhnfs > 0) then
        k = k+nhnfs
        err = 0
        do i =1, nhnfs
        call SmithNormalForm(HNFs(:,:,i),L, S, R, err_=err)
        if (err == 1) then
            print *, "overflow ",n
            print *, "HNF"
            do j=1,3
            print *, HNFs(j,:,i)
            end do
        end if
        end do
    end if
    end do
print *, "total number of HNFS", k

end PROGRAM lat_id_driver


C
C-----------------------------------------------------------------------
      SUBROUTINE EQNS(N,NUM,PI,HOVERD,HEIGHT,VALUE,DEPTH,CASE,CURRNT,
     $           Z,COSA,SINA,COEFF,SOL,Y,RHS)
C-----------------------------------------------------------------------
C
C     Evaluation of equations
C
C-----------------------------------------------------------------------
C
      implicit none

      CHARACTER*10 DEPTH,CASE,CURRNT
      INTEGER n,num
      REAL*8 PI,HOVERD,HEIGHT,VALUE,Z(num),COSA(0:num),SINA(0:num),
     $     COEFF(num),SOL(num,2),Y(num)
c      IMPLICIT REAL*8 (A-H,K,L,O-Z)
      real*8 :: RHS(num) !GD change: RHS(*)
C      real*8 :: RHS(*)
      integer :: i, it, nm, m, j
      real*8 :: e, c, s, psi, u, v
C
      IF(DEPTH.EQ.'finite') THEN
         RHS(1)=Z(2)-Z(1)*HOVERD
      ELSE
         RHS(1)=Z(1)+1.D0
      ENDIF
      IF(CASE.EQ.'wavelength') THEN
         RHS(2)=Z(2)-2.D0*PI*HEIGHT
      ELSE
         RHS(2)=Z(2)-HEIGHT*Z(3)**2
      ENDIF
      RHS(3)=Z(4)*Z(3)-PI-PI
      RHS(4)=Z(5)+Z(7)-Z(4)
      RHS(5)=Z(6)+Z(7)-Z(4)
      IF(DEPTH.EQ.'finite') THEN
         RHS(5)=RHS(5)-Z(8)/Z(1)
         DO 2 I=1,N
    2       COEFF(I)=Z(N+I+10)/DCOSH(I*Z(1))
      ENDIF
      IT=6
      IF(CURRNT.EQ.'Euler') IT=5
      RHS(6)=Z(IT)-VALUE*DSQRT(Z(2))
      RHS(7)=Z(10)+Z(N+10)
      DO 1 I=1,N-1
    1   RHS(7)=RHS(7)+Z(10+I)+Z(10+I)
      RHS(8)=Z(10)-Z(N+10)-Z(2)
      DO 3 M=0,N
         PSI=0.D0
         U=0.D0
         V=0.D0
         IF(DEPTH.EQ.'finite') THEN
            DO 4 J=1,N
               NM=MOD(M*J,N+N)
               E=DEXP(J*(Z(1)+Z(10+M)))
               S=0.5D0*(E-1.D0/E)
               C=0.5D0*(E+1.D0/E)
               PSI=PSI+COEFF(J)*S*COSA(NM)
               U=U+J*COEFF(J)*C*COSA(NM)
               V=V+J*COEFF(J)*S*SINA(NM)
    4       CONTINUE
         ELSE
            DO 5 J=1,N
               NM=MOD(M*J,N+N)
               E=DEXP(J*Z(10+M))
               PSI=PSI+Z(N+J+10)*E*COSA(NM)
               U=U+J*Z(N+J+10)*E*COSA(NM)
    5          V=V+J*Z(N+J+10)*E*SINA(NM)
         ENDIF
         RHS(M+9)=PSI-Z(8)-Z(7)*Z(M+10)
         RHS(N+M+10)=0.5D0*((-Z(7)+U)**2+V**2)+Z(M+10)-Z(9)
    3 CONTINUE
      RETURN
      END


* This file contains subroutines used for calculation of quantum yields for
* various photoreactions:
*     qyacet - q.y. for acetone, based on Blitz et al. (2004)

********************************************************************************

      SUBROUTINE qyacet(w, T, M, fco, fac)

* Compute acetone quantum yields according to the parameterization of:
* Blitz, M. A., D. E. Heard, M. J. Pilling, S. R. Arnold, and M. P. Chipperfield
*       (2004), Pressure and temperature-dependent quantum yields for the
*       photodissociation of acetone between 279 and 327.5 nm, Geophys.
*       Res. Lett., 31, L06111, doi:10.1029/2003GL018793.

      IMPLICIT NONE

* input:
* w = wavelength, nm
* T = temperature, K
* m = air number density, molec. cm-3

      REAL w, T, M

* internal:

      REAL a0, a1, a2, a3, a4
      REAL b0, b1, b2, b3, b4
      REAL c3
      REAL cA0, cA1, cA2, cA3, cA4

      real dumexp

* output
* fco = quantum yield for product CO
* fac = quantum yield for product CH3CO (acetyl radical)

      REAL fco, fac

*** set out-of-range values:
* use low pressure limits for shorter wavelengths
* set to zero beyound 327.5

      IF(w .LT. 279.) THEN
         fco = 0.05
         fac = 0.95
         RETURN
      ENDIF

      IF(w .GT. 327.) THEN
         fco = 0.
         fac = 0.
         RETURN
      ENDIF

*** CO (carbon monoxide) quantum yields:

      a0 = 0.350 * (T/295.)**(-1.28)
      b0 = 0.068 * (T/295.)**(-2.65)
**SM: prevent exponent overflow in rare cases:

      dumexp = b0*(w - 248.)
      if (dumexp .gt. 80.) then
         cA0 = 5.e34
      else
         cA0 = exp(dumexp) * a0 / (1. - a0)
      endif

      fco = 1. / (1. + cA0)

*** CH3CO (acetyl radical) quantum yields:

      IF(w .GE. 279. .AND. w .LT. 302.) THEN

         a1 = 1.600E-19 * (T/295.)**(-2.38)
         b1 = 0.55E-3   * (T/295.)**(-3.19)
         cA1 = a1 * EXP(-b1*((1.e7/w) - 33113.))

         fac = (1. - fco) / (1 + cA1 * M)

      ENDIF

      IF(w .GE. 302. .AND. w .LE. 327.) THEN

         a2 = 1.62E-17 * (T/295.)**(-10.03)
         b2 = 1.79E-3  * (T/295.)**(-1.364)
         cA2 = a2 * EXP(-b2*((1.e7/w) - 30488.))

         a3 = 26.29   * (T/295.)**(-6.59)
         b3 = 5.72E-7 * (T/295.)**(-2.93)
         c3 = 30006   * (T/295.)**(-0.064)
         ca3 = a3 * EXP(-b3*((1.e7/w) - c3)**2)

         a4 = 1.67E-15 * (T/295.)**(-7.25)
         b4 = 2.08E-3  * (T/295.)**(-1.16)
         cA4 = a4 * EXP(-b4*((1.e7/w) - 30488.))

         fac = (1. - fco) * (1. + cA3 + cA4 * M) /
     $        ((1. + cA3 + cA2 * M)*(1. + cA4 * M))

      ENDIF

      RETURN
      END

********************************************************************************


subroutine src2(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux,t,dt)

    use geoclaw_module, only: g => grav, coriolis_forcing, coriolis
    use geoclaw_module, only: friction_forcing, friction_depth
    use geoclaw_module, only: manning_coefficient
    use geoclaw_module, only: manning_break, num_manning

    implicit none

    ! Input parameters
    integer, intent(in) :: meqn,mbc,mx,my,maux
    double precision, intent(in) :: xlower,ylower,dx,dy,t,dt

    ! Output
    double precision, intent(inout) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    double precision, intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer :: i, j, nman
    real(kind=8) :: h, hu, hv, gamma, dgamma, y, fdt, a(2,2), coeff
    real(kind=8) :: x, q2, q2inflow, xforce

    ! Algorithm parameters
    ! Parameter controls when to zero out the momentum at a depth in the
    ! friction source term
    real(kind=8), parameter :: depth_tolerance = 1.0d-30

    ! Friction source term
    if (friction_forcing) then
        do j=1,my
            do i=1,mx
                x = xlower + (i-0.5d0)*dx
                ! Extract appropriate momentum
                if (q(1,i,j) < depth_tolerance) then
                    q(2:3,i,j) = 0.d0
                else
                    ! Apply friction source term only if in shallower water
                    ! MODIFIED for benchmark 1 problem, drive to hu at inflow
                    if (q(1,i,j) <= friction_depth) then
                        do nman = num_manning, 1, -1
                            if (aux(1,i,j) .lt. manning_break(nman)) then
                                coeff = manning_coefficient(nman)
                            endif
                        enddo
                        ! Calculate source term
                        if (x < xforce) then
                            gamma = 0.0055d0  ! based in inflow values, n=0.01
                            dgamma = 1.d0 + dt * gamma
                            !q2inflow = 0.054d0 * 0.115d0
                            q2inflow = q(1,i,j) * 0.115d0  ! use h here
                            q2 = (1.d0 - x/xforce) * q2inflow
                            q(2, i, j) = (q(2, i, j) - q2) / dgamma
                            q(3, i, j) = q(3, i, j) / dgamma
                          else
                            ! usual friction formulas
                            gamma = sqrt(q(2,i,j)**2 + q(3,i,j)**2) * g     &
                                  * coeff**2 / (q(1,i,j)**(7.d0/3.d0))
                            dgamma = 1.d0 + dt * gamma
                            q(2, i, j) = q(2, i, j) / dgamma
                            q(3, i, j) = q(3, i, j) / dgamma
                          endif
                    endif
                endif
            enddo
        enddo
    endif
    ! End of friction source term

    ! Coriolis source term
    ! TODO: May want to remove the internal calls to coriolis as this could
    !       lead to slow downs.
    if (coriolis_forcing) then
        do j=1,my
            y = ylower + (j - 0.5d0) * dy
            fdt = coriolis(y) * dt ! Calculate f dependent on coordinate system

            ! Calculate matrix components
            a(1,1) = 1.d0 - 0.5d0 * fdt**2 + fdt**4 / 24.d0
            a(1,2) =  fdt - fdt**3 / 6.d0
            a(2,1) = -fdt + fdt**3 / 6.d0
            a(2,2) = a(1,1)

            do i=1,mx
                q(2,i,j) = q(2, i, j) * a(1,1) + q(3, i, j) * a(1,2)
                q(3,i,j) = q(2, i, j) * a(2,1) + q(3, i, j) * a(2,2)
            enddo
        enddo
    endif
    ! End of coriolis source term

end subroutine src2


! History log

! 2017-05-12 Johnson, Y. Wang and X. Wang - define reflectivity opeator and its adjoint for WSM6 scheme, POC: xuguang.wang@ou.edu

module setupdbz_lib
public ::  hx_dart,jqr_dart,jqs_dart,jqg_dart
contains
subroutine hx_dart(qrgesin0,qggesin0,qsgesin0,rhogesin,tempgesin,rDBZ,debugging)
  use kinds, only: r_kind,r_double,i_kind
  use obsmod, only: static_gsi_nopcp_dbz
implicit none
real(r_kind) :: qrgesin0,qsgesin0,qggesin0
real(r_kind) :: qrgesin,qsgesin,qggesin,rhogesin,tempgesin,rDBZ
real(r_kind) :: zqr,zqg,zqs
logical :: debugging
real(r_kind) :: param_r,param_dry_g,param_wet_g,param_dry_s,param_wet_s
real(r_kind) ::n0r,n0s,n0g,rhor,rhos,rhog,dielectric,pi

 qrgesin=qrgesin0
 qsgesin=qsgesin0
 qggesin=qggesin0

pi=3.14159_r_kind
dielectric=0.224_r_kind
n0r=8e6_r_kind
n0s=3e6_r_kind !(2e6) !*exp(0.12*(min(273.15,tempgesin)-273.15)) !this is n0s in WSM6 paper, dif. from DART constant of 3e6
n0g=4e6_r_kind
rhos=100_r_kind
rhor=1000_r_kind
rhog=500_r_kind !this is rhog in WSM6 paper, dif. from DART 400

param_r=(7.2e20_r_kind)/(((pi*rhor)**1.75_r_kind)*(n0r**0.75_r_kind))
param_dry_g=dielectric*(rhog/rhor)*(rhog/rhor)*(7.2e20_r_kind)/(((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))
param_wet_g=(7.2e20_r_kind)/((((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))**0.95_r_kind)
param_wet_s=(7.2e20_r_kind)/(((pi*rhos)**1.75_r_kind)*(n0s**0.75_r_kind))
param_dry_s=dielectric*(rhos/rhor)*(rhos/rhor)*param_wet_s

zqr=param_r*((rhogesin*qrgesin)**1.75_r_kind)
if (tempgesin < 273.15_r_kind) then
  zqr=0_r_kind
  zqg=param_dry_g*((rhogesin*qggesin)**1.75_r_kind)
  zqs=param_dry_s*((rhogesin*qsgesin)**1.75_r_kind)
else if(tempgesin < 278.15_r_kind) then
  zqg=param_wet_g*((rhogesin*qggesin)**1.6675_r_kind)
  zqs=param_wet_s*((rhogesin*qsgesin)**1.75_r_kind)
else
  zqg=0_r_kind
  zqs=0_r_kind
endif
rDBZ=zqr+zqg+zqs
if (rdBZ > 1.0e-3_r_kind) then
  rdBZ=10_r_kind*log10(rdBZ)
else
  rdBZ=-30_r_kind
endif
if(rdBZ<static_gsi_nopcp_dbz) rdBZ=static_gsi_nopcp_dbz !notice, static_gsi_nopcp_dbz should be larger than -30

if(debugging) print *, "ZQR=",zqr,zqs,zqg,tempgesin

end subroutine hx_dart

subroutine jqr_dart(qrgesin0,qsgesin0,qggesin0,rhogesin,tempgesin,jqr)
  use kinds, only: r_kind,r_double,i_kind
implicit none
real(r_kind) :: qrgesin0,qsgesin0,qggesin0
real(r_kind) :: qrgesin,rhogesin,tempgesin,jqr
real(r_kind) :: Ze,zqr,zqg,zqs,qsgesin,qggesin

real(r_kind) :: param_r,param_dry_g,param_wet_g,param_dry_s,param_wet_s
real(r_kind) ::n0r,n0s,n0g,rhor,rhos,rhog,dielectric,pi,thisqrgesin
 qrgesin=qrgesin0
 qsgesin=qsgesin0
 qggesin=qggesin0

pi=3.14159_r_kind
dielectric=0.224_r_kind
n0r=8e6_r_kind
n0s=3e6_r_kind !(2e6) !*exp(0.12*(min(273.15,tempgesin)-273.15)) !this is n0s in WSM6 paper, dif. from DART constant of 3e6
n0g=4e6_r_kind
rhos=100_r_kind
rhor=1000_r_kind
rhog=500_r_kind !this is rhog in WSM6 paper, dif. from DART 400

param_r=(7.2e20_r_kind)/(((pi*rhor)**1.75_r_kind)*(n0r**0.75_r_kind))
param_dry_g=dielectric*(rhog/rhor)*(rhog/rhor)*(7.2e20_r_kind)/(((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))
param_wet_g=(7.2e20_r_kind)/((((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))**0.95_r_kind)
param_wet_s=(7.2e20_r_kind)/(((pi*rhos)**1.75_r_kind)*(n0s**0.75_r_kind))
param_dry_s=dielectric*(rhos/rhor)*(rhos/rhor)*param_wet_s

thisqrgesin=qrgesin
!calculate actual reflectivity
zqr=param_r*((rhogesin*qrgesin)**1.75_r_kind)
if (tempgesin < 273.15_r_kind) then
  zqr=0_r_kind
  thisqrgesin=0_r_kind
  zqg=param_dry_g*((rhogesin*qggesin)**1.75_r_kind)
  zqs=param_dry_s*((rhogesin*qsgesin)**1.75_r_kind)
else if (tempgesin < 278.15_r_kind) then
  zqg=param_wet_g*((rhogesin*qggesin)**1.6675_r_kind)
  zqs=param_wet_s*((rhogesin*qsgesin)**1.75_r_kind)
else
  zqg=0_r_kind
  zqs=0_r_kind
endif

Ze = zqr+zqg+zqs

if (tempgesin >= 273.15_r_kind) then
  jqr=(10_r_kind*param_r*(rhogesin**1.75_r_kind)*1.75_r_kind*(thisqrgesin**0.75_r_kind))/(log(10.0_r_kind)*Ze)
else
  jqr=0.0_r_kind
endif

end subroutine jqr_dart

subroutine jqs_dart(qrgesin0,qsgesin0,qggesin0,rhogesin,tempgesin,jqs)
  use kinds, only: r_kind,r_double,i_kind
implicit none
real(r_kind) :: qsgesin0,qggesin0,qrgesin0
real(r_kind) :: qsgesin,rhogesin,tempgesin,jqs
real(r_kind) :: Ze,qrgesin,qggesin,zqr,zqs,zqg

real(r_kind) :: param_r,param_dry_g,param_wet_g,param_dry_s,param_wet_s
real(r_kind) ::n0r,n0s,n0g,rhor,rhos,rhog,dielectric,pi,thisqsgesin
 qrgesin=qrgesin0
 qsgesin=qsgesin0
 qggesin=qggesin0

pi=3.14159_r_kind
dielectric=0.224_r_kind
n0r=8e6_r_kind
n0s=3e6_r_kind !(2e6) !*exp(0.12*(min(273.15,tempgesin)-273.15)) !this is n0s in WSM6 paper, dif. from DART constant of 3e6
n0g=4e6_r_kind !values taken from jung et al 2008/lfo83
rhos=100_r_kind
rhor=1000_r_kind
rhog=500_r_kind !this is rhog in WSM6 paper, dif. from DART 400

param_r=(7.2e20_r_kind)/(((pi*rhor)**1.75_r_kind)*(n0r**0.75_r_kind))
param_dry_g=dielectric*(rhog/rhor)*(rhog/rhor)*(7.2e20_r_kind)/(((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))
param_wet_g=(7.2e20_r_kind)/((((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))**0.95_r_kind)
param_wet_s=(7.2e20_r_kind)/(((pi*rhos)**1.75_r_kind)*(n0s**0.75_r_kind))
param_dry_s=dielectric*(rhos/rhor)*(rhos/rhor)*param_wet_s

thisqsgesin=qsgesin
!calculate actual reflectivity
zqr=param_r*((rhogesin*qrgesin)**1.75_r_kind)
if (tempgesin < 273.15_r_kind) then
  zqr=0_r_kind
  zqg=param_dry_g*((rhogesin*qggesin)**1.75_r_kind)
  zqs=param_dry_s*((rhogesin*qsgesin)**1.75_r_kind)
else if (tempgesin < 278.15_r_kind) then
  zqg=param_wet_g*((rhogesin*qggesin)**1.6675_r_kind)
  zqs=param_wet_s*((rhogesin*qsgesin)**1.75_r_kind)
else
  zqg=0_r_kind
  zqs=0_r_kind
  thisqsgesin=0.0_r_kind
endif

Ze = zqr+zqg+zqs
if (tempgesin < 273.15_r_kind) then
  jqs=(10_r_kind*param_dry_s*(rhogesin**1.75_r_kind)*1.75_r_kind*(thisqsgesin**0.75_r_kind))/(log(10.0_r_kind)*Ze)
else
  jqs=(10_r_kind*param_wet_s*(rhogesin**1.75_r_kind)*1.75_r_kind*(thisqsgesin**0.75_r_kind))/(log(10.0_r_kind)*Ze)
endif

end subroutine jqs_dart

subroutine jqg_dart(qrgesin0,qsgesin0,qggesin0,rhogesin,tempgesin,jqg)
  use kinds, only: r_kind,r_double,i_kind
implicit none
real(r_kind) :: qggesin0,qsgesin0,qrgesin0
real(r_kind) :: qggesin,rhogesin,tempgesin,jqg
real(r_kind) :: Ze,qrgesin,qsgesin,zqr,zqs,zqg,thisqggesin

real(r_kind) :: param_r,param_dry_g,param_wet_g,param_dry_s,param_wet_s
real(r_kind) ::n0r,n0s,n0g,rhor,rhos,rhog,dielectric,pi
 qrgesin=qrgesin0
 qsgesin=qsgesin0
 qggesin=qggesin0

pi=3.14159_r_kind
dielectric=0.224_r_kind
n0r=8e6_r_kind
n0s=3e6_r_kind !(2e6) !*exp(0.12*(min(273.15,tempgesin)-273.15)) !this is n0s in WSM6 paper, dif. from DART constant of 3e6
n0g=4e6_r_kind
rhos=100_r_kind
rhor=1000_r_kind
rhog=500_r_kind !this is rhog in WSM6 paper, dif. from DART 400

param_r=(7.2e20_r_kind)/(((pi*rhor)**1.75_r_kind)*(n0r**0.75_r_kind))
param_dry_g=dielectric*(rhog/rhor)*(rhog/rhor)*(7.2e20_r_kind)/(((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))
param_wet_g=(7.2e20_r_kind)/((((pi*rhog)**1.75_r_kind)*(n0g**0.75_r_kind))**0.95_r_kind)
param_wet_s=(7.2e20_r_kind)/(((pi*rhos)**1.75_r_kind)*(n0s**0.75_r_kind))
param_dry_s=dielectric*(rhos/rhor)*(rhos/rhor)*param_wet_s

thisqggesin=qggesin
!calculate actual reflectivity
zqr=param_r*((rhogesin*qrgesin)**1.75_r_kind)
if (tempgesin < 273.15_r_kind) then
  zqr=0_r_kind
  zqg=param_dry_g*((rhogesin*qggesin)**1.75_r_kind)
  zqs=param_dry_s*((rhogesin*qsgesin)**1.75_r_kind)
else if (tempgesin < 278.15_r_kind) then
  zqg=param_wet_g*((rhogesin*qggesin)**1.6675_r_kind)
  zqs=param_wet_s*((rhogesin*qsgesin)**1.75_r_kind)
else
  zqg=0_r_kind
  zqs=0_r_kind
  thisqggesin=0.0_r_kind
endif

Ze = zqr+zqg+zqs

if (tempgesin < 273.15_r_kind) then
  jqg=(10_r_kind*param_dry_g*(rhogesin**1.75_r_kind)*1.75_r_kind*(thisqggesin**0.75_r_kind))/(log(10.0_r_kind)*Ze)
else
  jqg=(10_r_kind*param_wet_g*(rhogesin**1.6675_r_kind)*1.6675_r_kind*(thisqggesin**0.6675_r_kind))/(log(10.0_r_kind)*Ze)
endif
end subroutine jqg_dart

!hydrometeor first guess values are in g/kg but note that equations use kg/kg
subroutine hx_gaostensrud2012(qrgesin,qggesin,qsgesin,rhogesin,tempgesin,rDBZ)
  use kinds, only: r_kind,r_double,i_kind
implicit none
real(r_kind) :: qrgesin,qsgesin,qggesin,rhogesin,tempgesin,rDBZ
real(r_kind) :: zqr,zqg,zqs

zqr=(3.63e9_r_kind)*((rhogesin*qrgesin)**1.75_r_kind)
zqg=(4.33e10_r_kind)*((rhogesin*qggesin)**1.75_r_kind)
if(tempgesin < 273.15_r_kind) then
  zqs=(9.8e8_r_kind)*((rhogesin*qsgesin)**1.75_r_kind)
else
  zqs=(4.26e11_r_kind)*((rhogesin*qsgesin)**1.75_r_kind)
endif
rDBZ=zqr+zqg+zqs
if (rdBZ > 1_r_kind) then
  rdBZ=10_r_kind*log10(rdBZ)
else
  rdBZ=0_r_kind
endif

!reflectivity threshold for no-precip:
if (rdBZ < 5_r_kind) rdBZ=5_r_kind

end subroutine hx_gaostensrud2012
end module setupdbz_lib


MODULE hrmc_functions

  use model_mod
  implicit none

CONTAINS

    function chi_square(alpha,vk_exp, vk_exp_err, vk, scale_fac, nk)
        double precision :: alpha
        double precision, pointer, dimension(:) :: vk_exp, vk_exp_err
        double precision, pointer, dimension(:) :: vk
        double precision, intent(in) :: scale_fac
        integer, intent(in) ::nk
        integer j
        integer nf   ! normalization factor
        double precision :: chi_square
        chi_square=0.0

        nf = 0
        do j=1,nk
            nf = nf + 1
            chi_square = chi_square+alpha*((vk_exp(j)*scale_fac-vk(j))/(scale_fac*vk_exp_err(j)))**2
        enddo
        chi_square = chi_square/nf
    end function chi_square

    ! Returns .true. if no two atoms are within cutoff distance.
    ! Otherwise returns .false.
    function check_cutoffs(m,cutoff_r,moved_atom)
        logical check_cutoffs
        double precision,dimension(:,:) ::cutoff_r
        integer moved_atom
        type(model) m
        integer, dimension(:), pointer :: atoms
        integer  nlist
        integer istat
        double precision radius, temp_x, temp_y, temp_z
        integer i,j
        integer num1, num2
        double precision dist_pair

        ! Find the maximum cut-off distance
        radius = maxval(maxval(cutoff_r, 1),1)

        ! Find all atoms within radius radius of moved_atom and put them
        ! in the list atoms. Also sets nlist == size(atoms)+1.
        call hutch_list_3D(m, m%xx%ind(moved_atom), m%yy%ind(moved_atom), m%zz%ind(moved_atom), radius, atoms, istat, nlist)
        if (istat .eq. 1) then
            write(stderr, *) 'memory allocation fails!'
            return
        else if(istat .eq. -1) then
            write(stderr, *) 'no atom is found'
            check_cutoffs = .true.
            return
        endif

        ! First, determine the type of moved_atom so we can use it in cutoff_r
        do i=1, m%nelements
            if(m%znum%ind(moved_atom) .eq. m%atom_type(i)) then
                num1 = i
                exit
            endif
        enddo

        do i=1, (nlist-1)
            ! Do not count the pair distance to itself
            ! The below if statement should be irrelevant. moved_atom isn't put
            ! in atoms by hutch_list_3d as far as i know. However, it's a nice
            ! safety feature and pretty irrelelvant.
            check_cutoffs = .true.
            if (atoms(i) .ne. moved_atom) then
                do j=1, m%nelements
                    if(m%atom_type(j) .eq. m%znum%ind(atoms(i))) then
                        num2 = j
                        exit
                    endif
                enddo !j=1, m%nelements

                !calculate the atomic distance and compare with cutoff_r
                temp_x = m%xx%ind(moved_atom) - m%xx%ind(atoms(i))  ! periodic boundary conditions
                temp_y = m%yy%ind(moved_atom) - m%yy%ind(atoms(i))
                temp_z = m%zz%ind(moved_atom) - m%zz%ind(atoms(i))
                temp_x = temp_x - m%lx*anint(temp_x/m%lx)
                temp_y = temp_y - m%ly*anint(temp_y/m%ly)
                temp_z = temp_z - m%lz*anint(temp_z/m%lz)

                dist_pair = temp_x**2 + temp_y**2 + temp_z**2
                dist_pair = sqrt(dist_pair)

                if (dist_pair  .lt. cutoff_r(num1, num2)) then
                    check_cutoffs=.false.
                    exit
                endif
            endif
        enddo

        if (nlist .gt. 1) deallocate(atoms)
    end function check_cutoffs

  ! Generates a random move of one atom.
  ! The actual positions are not changed, just returned.
  subroutine random_move(m, w, xx_cur, yy_cur, zz_cur, xx_new, yy_new, zz_new, alpha)
    type(model), intent(inout) :: m
    integer, intent(out) :: w
    double precision, intent(out) :: xx_cur, yy_cur, zz_cur, xx_new, yy_new, zz_new
    double precision, intent(in) :: alpha
    integer :: iseed
    double precision :: rand1, rand2, rand3, rand4
    double precision :: aa, bb, cc

    iseed = 791315

    call random_number(rand1)
    call random_number(rand2)
    call random_number(rand3)
    call random_number(rand4)

    w = int(m%natoms*rand1)+1

    ! Current positions of the atom before random move
    xx_cur = m%xx%ind(w)
    yy_cur = m%yy%ind(w)
    zz_cur = m%zz%ind(w)

    aa = alpha*(rand2 - 0.5)
    bb = alpha*(rand3 - 0.5)
    cc = alpha*(rand4 - 0.5)

    m%xx%ind(w) = m%xx%ind(w) + aa
    m%yy%ind(w) = m%yy%ind(w) + bb
    m%zz%ind(w) = m%zz%ind(w) + cc

    ! Periodic boundary conditions
    if(m%xx%ind(w) >  m%lx*0.5) m%xx%ind(w) = m%xx%ind(w) - m%lx
    if(m%yy%ind(w) >  m%ly*0.5) m%yy%ind(w) = m%yy%ind(w) - m%ly
    if(m%zz%ind(w) >  m%lz*0.5) m%zz%ind(w) = m%zz%ind(w) - m%lz
    if(m%xx%ind(w) < -m%lx*0.5) m%xx%ind(w) = m%xx%ind(w) + m%lx
    if(m%yy%ind(w) < -m%ly*0.5) m%yy%ind(w) = m%yy%ind(w) + m%ly
    if(m%zz%ind(w) < -m%lz*0.5) m%zz%ind(w) = m%zz%ind(w) + m%lz

    ! New positions of the atom after random move
    xx_new = m%xx%ind(w)
    yy_new = m%yy%ind(w)
    zz_new = m%zz%ind(w)
  end subroutine random_move

END MODULE hrmc_functions


program househ_ppal

use househ_interface
use sistu_interface
use datasissim_interface
use residuo_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:,:), allocatable :: a_copia
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: b_copia
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: r

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

n = 6

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), a_copia(n,n), b(n), b_copia(n), u(n), r(n))

u = 0

!call datasissim(a, b)

do i=1,n
  do j =1,n
    if(i == j) then
      a(i,i) = 2
    else
      a(i,j) = j - i
    end if
  end do
  print *, a(i,:)
end do

do i =1,n
  b(i) = 2*i
end do

a_copia = a

b_copia = b

call househ(a, b, deter)

print*, 'A matriz A e: '

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

print*, 'B é:'
print*, b(:)

call sistu(a, b, u)
call residuo(a_copia, b_copia, u, r)

print*,
print*, 'Vector u (Solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

if(allocated(a_copia)) deallocate(a_copia)

if(allocated(b_copia)) deallocate(b_copia)

end program


! { dg-do run }

  use :: ieee_arithmetic
  use :: iso_fortran_env, only : real_kinds
  implicit none

  ! This should be
  ! integer, parameter :: maxreal = maxval(real_kinds)
  ! but it works because REAL_KINDS happen to be in increasing order
  integer, parameter :: maxreal = real_kinds(size(real_kinds))

  ! Test IEEE_SELECTED_REAL_KIND in specification expressions

  integer(kind=ieee_selected_real_kind()) :: i1
  integer(kind=ieee_selected_real_kind(10)) :: i2
  integer(kind=ieee_selected_real_kind(10,10)) :: i3
  integer(kind=ieee_selected_real_kind(10,10,2)) :: i4

  ! Test IEEE_SELECTED_REAL_KIND

  if (ieee_support_datatype(0.)) then
    if (ieee_selected_real_kind() /= kind(0.)) call abort
    if (ieee_selected_real_kind(0) /= kind(0.)) call abort
    if (ieee_selected_real_kind(0,0) /= kind(0.)) call abort
    if (ieee_selected_real_kind(0,0,2) /= kind(0.)) call abort
  end if

  if (ieee_support_datatype(0.d0)) then
    if (ieee_selected_real_kind(precision(0.)+1) /= kind(0.d0)) call abort
    if (ieee_selected_real_kind(precision(0.),range(0.)+1) /= kind(0.d0)) call abort
    if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1) /= kind(0.d0)) call abort
    if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1,2) /= kind(0.d0)) call abort
  end if

  if (ieee_selected_real_kind(0,0,3) /= -5) call abort
  if (ieee_selected_real_kind(100*precision(0._maxreal)) /= -1) call abort
  if (ieee_selected_real_kind(0,100*range(0._maxreal)) /= -2) call abort
  if (ieee_selected_real_kind(100*precision(0._maxreal),100*range(0._maxreal)) /= -3) call abort

end


module test_moment
    use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
    use stdlib_kinds, only: sp, dp, int32, int64
    use stdlib_stats, only: moment
    use testdrive, only: new_unittest, unittest_type, error_type, check

    implicit none

    private
    public :: collect_moment, initialize_test_data

    real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
    real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

    real(dp), parameter :: d1(5) = [1._dp, 2._dp, 3._dp, 4._dp, 5._dp]
    real(dp), parameter :: d(4,3) = reshape( &
        [1._dp, 3._dp, 5._dp, 7._dp, &
         2._dp, 4._dp, 6._dp, 8._dp, &
         9._dp, 10._dp, 11._dp, 12._dp], [4, 3])

    complex(dp) :: c1(5) = [(0.57706_dp, 0.00000_dp), &
                            (0.00000_dp, 1.44065_dp), &
                            (1.26401_dp, 0.00000_dp), &
                            (0.00000_dp, 0.88833_dp), &
                            (1.14352_dp, 0.00000_dp)]
    complex(dp) :: c2(5,3)

    real(sp) :: x1(5) = real(d1, sp)
    real(sp) :: x2(4,3) = real(d, sp)
    real(sp), allocatable :: x3(:,:,:)

    real(dp) :: dx1(5) = d1
    real(dp) :: dx2(4,3) = d
    real(dp), allocatable :: dx3(:,:,:)

    integer(int32) :: i1(5) = d1
    integer(int32) :: i2(4,3) = d
    integer(int32), allocatable :: i3(:,:,:)

    integer(int64) :: di1(5) = d1
    integer(int64) :: di2(4,3) = d
    integer(int64), allocatable :: di3(:,:,:)

contains

    subroutine initialize_test_data()

        allocate(x3(size(x2, 1),size(x2, 2),3))
        x3(:,:,1) = x2
        x3(:,:,2) = x2 * 2
        x3(:,:,3) = x2 * 4

        allocate(dx3(size(dx2, 1),size(dx2, 2),3))
        dx3(:,:,1) = dx2
        dx3(:,:,2) = dx2 * 2
        dx3(:,:,3) = dx2 * 4

        i3 = x3
        di3 = dx3

        c2(:,1) = c1
        c2(:,2) = c1 * 3
        c2(:,3) = c1 * 1.5

    end subroutine initialize_test_data

    !> Collect all exported unit tests
    subroutine collect_moment(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest('moment_sp_dim1_order1', test_sp_dim1_order1), &
            new_unittest('moment_sp_dim1_mask_order1', test_sp_dim1_mask_order1), &
            new_unittest('moment_sp_dim1_mask_array_order1', test_sp_dim1_mask_array_order1), &
            new_unittest('moment_sp_dim2_order1', test_sp_dim2_order1), &
            new_unittest('moment_sp_dim2_mask_order1', test_sp_dim2_mask_order1), &
            new_unittest('moment_sp_dim2_mask_array_order1', test_sp_dim2_mask_array_order1), &
            new_unittest('moment_sp_dim3_order1', test_sp_dim3_order1), &
            new_unittest('moment_sp_dim3_mask_order1', test_sp_dim3_mask_order1), &
            new_unittest('moment_sp_dim3_mask_array_order1', test_sp_dim3_mask_array_order1), &
            new_unittest('moment_sp_dim1_order2', test_sp_dim1_order2), &
            new_unittest('moment_sp_dim1_mask_order2', test_sp_dim1_mask_order2), &
            new_unittest('moment_sp_dim1_mask_array_order2', test_sp_dim1_mask_array_order2), &
            new_unittest('moment_sp_dim2_order2', test_sp_dim2_order2), &
            new_unittest('moment_sp_dim2_mask_order2', test_sp_dim2_mask_order2), &
            new_unittest('moment_sp_dim2_mask_array_order2', test_sp_dim2_mask_array_order2), &
            new_unittest('moment_sp_dim3_order2', test_sp_dim3_order2), &
            new_unittest('moment_sp_dim3_mask_order2', test_sp_dim3_mask_order2), &
            new_unittest('moment_sp_dim3_mask_array_order2', test_sp_dim3_mask_array_order2), &
            new_unittest('moment_dp_dim1_order1', test_dp_dim1_order1), &
            new_unittest('moment_dp_dim1_mask_order1', test_dp_dim1_mask_order1), &
            new_unittest('moment_dp_dim1_mask_array_order1', test_dp_dim1_mask_array_order1), &
            new_unittest('moment_dp_dim2_order1', test_dp_dim2_order1), &
            new_unittest('moment_dp_dim2_mask_order1', test_dp_dim2_mask_order1), &
            new_unittest('moment_dp_dim2_mask_array_order1', test_dp_dim2_mask_array_order1), &
            new_unittest('moment_dp_dim3_order1', test_dp_dim3_order1), &
            new_unittest('moment_dp_dim3_mask_order1', test_dp_dim3_mask_order1), &
            new_unittest('moment_dp_dim3_mask_array_order1', test_dp_dim3_mask_array_order1), &
            new_unittest('moment_dp_dim1_order2', test_dp_dim1_order2), &
            new_unittest('moment_dp_dim1_mask_order2', test_dp_dim1_mask_order2), &
            new_unittest('moment_dp_dim1_mask_array_order2', test_dp_dim1_mask_array_order2), &
            new_unittest('moment_dp_dim2_order2', test_dp_dim2_order2), &
            new_unittest('moment_dp_dim2_mask_order2', test_dp_dim2_mask_order2), &
            new_unittest('moment_dp_dim2_mask_array_order2', test_dp_dim2_mask_array_order2), &
            new_unittest('moment_dp_dim3_order2', test_dp_dim3_order2), &
            new_unittest('moment_dp_dim3_mask_order2', test_dp_dim3_mask_order2), &
            new_unittest('moment_dp_dim3_mask_array_order2', test_dp_dim3_mask_array_order2), &
            new_unittest('moment_int32_dim1_order1', test_int32_dim1_order1), &
            new_unittest('moment_int32_dim1_mask_order1', test_int32_dim1_mask_order1), &
            new_unittest('moment_int32_dim1_mask_array_order1', test_int32_dim1_mask_array_order1), &
            new_unittest('moment_int32_dim2_order1', test_int32_dim2_order1), &
            new_unittest('moment_int32_dim2_mask_order1', test_int32_dim2_mask_order1), &
            new_unittest('moment_int32_dim2_mask_array_order1', test_int32_dim2_mask_array_order1), &
            new_unittest('moment_int32_dim3_order1', test_int32_dim3_order1), &
            new_unittest('moment_int32_dim3_mask_order1', test_int32_dim3_mask_order1), &
            new_unittest('moment_int32_dim3_mask_array_order1', test_int32_dim3_mask_array_order1), &
            new_unittest('moment_int32_dim1_order2', test_int32_dim1_order2), &
            new_unittest('moment_int32_dim1_mask_order2', test_int32_dim1_mask_order2), &
            new_unittest('moment_int32_dim1_mask_array_order2', test_int32_dim1_mask_array_order2), &
            new_unittest('moment_int32_dim2_order2', test_int32_dim2_order2), &
            new_unittest('moment_int32_dim2_mask_order2', test_int32_dim2_mask_order2), &
            new_unittest('moment_int32_dim2_mask_array_order2', test_int32_dim2_mask_array_order2), &
            new_unittest('moment_int32_dim3_order2', test_int32_dim3_order2), &
            new_unittest('moment_int32_dim3_mask_order2', test_int32_dim3_mask_order2), &
            new_unittest('moment_int32_dim3_mask_array_order2', test_int32_dim3_mask_array_order2), &
            new_unittest('moment_int64_dim1_order1', test_int64_dim1_order1), &
            new_unittest('moment_int64_dim1_mask_order1', test_int64_dim1_mask_order1), &
            new_unittest('moment_int64_dim1_mask_array_order1', test_int64_dim1_mask_array_order1), &
            new_unittest('moment_int64_dim2_order1', test_int64_dim2_order1), &
            new_unittest('moment_int64_dim2_mask_order1', test_int64_dim2_mask_order1), &
            new_unittest('moment_int64_dim2_mask_array_order1', test_int64_dim2_mask_array_order1), &
            new_unittest('moment_int64_dim3_order1', test_int64_dim3_order1), &
            new_unittest('moment_int64_dim3_mask_order1', test_int64_dim3_mask_order1), &
            new_unittest('moment_int64_dim3_mask_array_order1', test_int64_dim3_mask_array_order1), &
            new_unittest('moment_int64_dim1_order2', test_int64_dim1_order2), &
            new_unittest('moment_int64_dim1_mask_order2', test_int64_dim1_mask_order2), &
            new_unittest('moment_int64_dim1_mask_array_order2', test_int64_dim1_mask_array_order2), &
            new_unittest('moment_int64_dim2_order2', test_int64_dim2_order2), &
            new_unittest('moment_int64_dim2_mask_order2', test_int64_dim2_mask_order2), &
            new_unittest('moment_int64_dim2_mask_array_order2', test_int64_dim2_mask_array_order2), &
            new_unittest('moment_int64_dim3_order2', test_int64_dim3_order2), &
            new_unittest('moment_int64_dim3_mask_order2', test_int64_dim3_mask_order2), &
            new_unittest('moment_int64_dim3_mask_array_order2', test_int64_dim3_mask_array_order2), &
            new_unittest('moment_csp_dim1_order1', test_csp_dim1_order1), &
            new_unittest('moment_csp_dim1_mask_order1', test_csp_dim1_mask_order1), &
            new_unittest('moment_csp_dim1_mask_array_order1', test_csp_dim1_mask_array_order1), &
            new_unittest('moment_csp_dim2_order1', test_csp_dim2_order1), &
            new_unittest('moment_csp_dim2_mask_order1', test_csp_dim2_mask_order1), &
            new_unittest('moment_csp_dim2_mask_array_order1', test_csp_dim2_mask_array_order1), &
            new_unittest('moment_csp_dim1_order2', test_csp_dim1_order2), &
            new_unittest('moment_csp_dim1_mask_order2', test_csp_dim1_mask_order2), &
            new_unittest('moment_csp_dim1_mask_array_order2', test_csp_dim1_mask_array_order2), &
            new_unittest('moment_csp_dim2_order2', test_csp_dim2_order2), &
            new_unittest('moment_csp_dim2_mask_order2', test_csp_dim2_mask_order2), &
            new_unittest('moment_csp_dim2_mask_array_order2', test_csp_dim2_mask_array_order2) &
        ]

    end subroutine collect_moment

    subroutine test_sp_dim1_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x1, order)) < sptol)
        call check(error, abs(moment(x1, order, dim=1)) < sptol)
    end subroutine

    subroutine test_sp_dim1_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(x1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(x1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_sp_dim1_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x1, order, mask=(x1 < 5))) < sptol)
        call check(error, abs(moment(x1, order, 1, mask=(x1 < 5))) < sptol)
    end subroutine

    subroutine test_sp_dim2_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x2, order)) < sptol)
        call check(error, all(abs(moment(x2, order, 1)) < sptol))
        call check(error, all(abs(moment(x2, order, 2)) < sptol))
    end subroutine

    subroutine test_sp_dim2_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(x2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_sp_dim2_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x2, order, mask=(x2 < 11))) < sptol)
        call check(error, all(abs(moment(x2, order, 1, mask=(x2 < 11))) < sptol))
        call check(error, all(abs(moment(x2, order, 2, mask=(x2 < 11))) < sptol))
    end subroutine

    subroutine test_sp_dim3_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x3, order)) < sptol)
        call check(error, all(abs(moment(x3, order, 1)) < sptol))
        call check(error, all(abs(moment(x3, order, 2)) < sptol))
        call check(error, all(abs(moment(x3, order, 3)) < sptol))
    end subroutine

    subroutine test_sp_dim3_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(x3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_sp_dim3_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(x3, order, mask=(x3 < 11)) ) < sptol)
        call check(error, all(abs(moment(x3, order, 1, mask=(x3 < 45))) < sptol ))
        call check(error, all(abs(moment(x3, order, 2, mask=(x3 < 45))) < sptol ))
        call check(error, all(abs(moment(x3, order, 3, mask=(x3 < 45))) < sptol ))
    end subroutine

    subroutine test_sp_dim1_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x1, order) - 2._sp) < sptol)
        call check(error, abs(moment(x1, order, dim=1) - 2._sp) < sptol)
    end subroutine

    subroutine test_sp_dim1_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(x1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(x1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_sp_dim1_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x1, order, mask=(x1 < 5)) - 1.25_sp) < sptol)
        call check(error, abs(moment(x1, order, 1, mask=(x1 < 5)) - 1.25_sp) < sptol)
    end subroutine

    subroutine test_sp_dim2_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x2, order) - 107.25_sp/9.) < sptol)
        call check(error, all(abs(moment(x2, order, 1) - [5._sp, 5._sp, 1.25_sp]) < sptol))
        call check(error, all(abs(moment(x2, order, 2) -&
                           [19.0, 43. / 3., 31. / 3. , 7.0]*2./3.) < sptol))
    end subroutine

    subroutine test_sp_dim2_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(x2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(x2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_sp_dim2_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x2, order, mask=(x2 < 11))- 2.75_sp*3.) < sptol)
        call check(error, all(abs(moment(x2, order, 1, mask=(x2 < 11)) -&
                      [5._sp, 5._sp, 0.25_sp]) < sptol))
        call check(error, all(abs(moment(x2, order, 2, mask=(x2 < 11)) -&
                      [19._sp*2./3., 43._sp/9.*2., 0.25_sp , 0.25_sp]) < sptol))
    end subroutine

    subroutine test_sp_dim3_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x3, order) - 153.4_sp*35./36.) < sptol)
        call check(error, all(abs(moment(x3, order, 1) -&
                 reshape([20._sp / 3., 20._sp / 3., 5._sp / 3.,&
                          4* 20._sp / 3., 4* 20._sp / 3., 4* 5._sp / 3.,&
                          16* 20._sp / 3., 16* 20._sp / 3., 16* 5._sp / 3.],&
                          [size(x3,2), size(x3,3)])*3._sp/4.)&
                 < sptol))
        call check(error, all(abs(moment(x3, order, 2) -&
                 reshape([19._sp, 43._sp / 3., 31._sp / 3. , 7.0_sp,&
                          4* 19.0_sp, 4* 43._sp / 3., 4* 31._sp / 3. , 4* 7.0_sp,&
                          16* 19.0_sp, 16* 43._sp / 3., 16* 31._sp / 3. , 16* 7.0_sp],&
                          [size(x3,1), size(x3,3)] )*2._sp/3.)&
                 < sptol))
        call check(error, all(abs(moment(x3, order, 3) -&
                 reshape([ 7._sp/3., 21._sp, 175._sp/3.,&
                           343._sp/3., 28._sp/3., 112._sp/3.,&
                           84._sp, 448._sp/3., 189._sp,&
                           700._sp/3., 847._sp/3., 336._sp],&
                           [size(x3,1), size(x3,2)] )*2./3.)&
                 < sptol))
    end subroutine

    subroutine test_sp_dim3_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(x3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(x3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(x3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_sp_dim3_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(x3, order, mask=(x3 < 11)) -&
                      7.7370242214532876_dp ) < sptol)
        call check(error, all(abs(moment(x3, order, 1, mask=(x3 < 45)) -&
                      reshape([5._sp, 5._sp, 1.25_sp,  20._sp, 20._sp, 5._sp,&
                               80._sp, 80._sp, 32._sp/3.],&
                               [size(x3, 2), size(x3, 3)])) < sptol ))
        call check(error, all(abs(moment(x3, order, 2, mask=(x3 < 45)) -&
                      reshape([ 38._sp/3., 86._sp/9., 62._sp/9., 14._sp/3., 152._sp/3.,&
                                344._sp/9., 248._sp/9., 168._sp/9., 1824._sp/9.,&
                                1376._sp/9., 992._sp/9., 4._sp&
                               ],&
                      [size(x3, 1), size(x3, 3)])) < sptol ))
        call check(error, all(abs(moment(x3, order, 3, mask=(x3 < 45)) -&
                     reshape([14._sp/9., 14._sp, 350._sp/9., 686._sp/9., 56._sp/9.,&
                              224._sp/9., 56._sp, 896._sp/9., 126._sp, 1400._sp/9.,&
                              1694._sp/9., 36._sp&
                               ], [size(x3,1), size(x3,2)] ))&
                     < sptol ))
    end subroutine

    subroutine test_dp_dim1_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx1, order)) < dptol)
        call check(error, abs(moment(dx1, order, dim=1)) < dptol)
    end subroutine

    subroutine test_dp_dim1_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(dx1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(dx1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_dp_dim1_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx1, order, mask=(dx1 < 5))) < dptol)
        call check(error, abs(moment(dx1, order, 1, mask=(dx1 < 5))) < dptol)
    end subroutine

    subroutine test_dp_dim2_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx2, order)) < dptol)
        call check(error, all(abs(moment(dx2, order, 1)) < dptol))
        call check(error, all(abs(moment(dx2, order, 2)) < dptol))
    end subroutine

    subroutine test_dp_dim2_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(dx2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(dx2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_dp_dim2_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx2, order, mask=(dx2 < 11))) < dptol)
        call check(error, all(abs(moment(dx2, order, 1, mask=(dx2 < 11))) < dptol))
        call check(error, all(abs(moment(dx2, order, 2, mask=(dx2 < 11))) < dptol))
    end subroutine

    subroutine test_dp_dim3_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx3, order)) < dptol)
        call check(error, all(abs(moment(dx3, order, 1)) < dptol))
        call check(error, all(abs(moment(dx3, order, 2)) < dptol))
        call check(error, all(abs(moment(dx3, order, 3)) < dptol))
    end subroutine

    subroutine test_dp_dim3_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(dx3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(dx3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_dp_dim3_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(dx3, order, mask=(dx3 < 11)) ) < dptol)
        call check(error, all(abs(moment(dx3, order, 1, mask=(dx3 < 45))) < dptol ))
        call check(error, all(abs(moment(dx3, order, 2, mask=(dx3 < 45))) < dptol ))
        call check(error, all(abs(moment(dx3, order, 3, mask=(dx3 < 45))) < dptol ))
    end subroutine

    subroutine test_dp_dim1_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx1, order) - 2._dp) < dptol)
        call check(error, abs(moment(dx1, order, dim=1) - 2._dp) < dptol)
    end subroutine

    subroutine test_dp_dim1_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(dx1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(dx1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_dp_dim1_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx1, order, mask=(dx1 < 5)) - 1.25_dp) < dptol)
        call check(error, abs(moment(dx1, order, 1, mask=(dx1 < 5)) - 1.25_dp) < dptol)
    end subroutine

    subroutine test_dp_dim2_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx2, order) - 107.25_dp/9.) < dptol)
        call check(error, all(abs(moment(dx2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
        call check(error, all(abs(moment(dx2, order, 2) -&
                      [19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
    end subroutine

    subroutine test_dp_dim2_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(dx2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(dx2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_dp_dim2_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx2, order, mask=(dx2 < 11))- 2.75_dp*3.) < dptol)
        call check(error, all(abs(moment(dx2, order, 1, mask=(dx2 < 11)) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
        call check(error, all(abs(moment(dx2, order, 2, mask=(dx2 < 11)) -&
                      [19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
    end subroutine

    subroutine test_dp_dim3_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx3, order) - 153.4_dp*35./36.) < dptol)
        call check(error, all(abs(moment(dx3, order, 1) -&
                 reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
                          4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
                          16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
                          [size(dx3,2), size(dx3,3)])*3._dp/4.)&
                 < dptol))
        call check(error, all(abs(moment(dx3, order, 2) -&
                 reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
                          [size(dx3,1), size(dx3,3)] )*2._dp/3.)&
                 < dptol))
        call check(error, all(abs(moment(dx3, order, 3) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(dx3,1), size(dx3,2)] )*2./3.)&
                 < dptol))
    end subroutine

    subroutine test_dp_dim3_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(dx3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(dx3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(dx3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_dp_dim3_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(dx3, order, mask=(dx3 < 11)) -&
                          7.7370242214532876_dp ) < dptol)
        call check(error, all(abs(moment(dx3, order, 1, mask=(dx3 < 45)) -&
                      reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                               80._dp, 80._dp, 32._dp/3.],&
                               [size(dx3, 2), size(dx3, 3)])) < dptol ))
        call check(error, all(abs(moment(dx3, order, 2, mask=(dx3 < 45)) -&
                      reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                                344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                                1376._dp/9., 992._dp/9., 4._dp&
                               ],&
                      [size(dx3, 1), size(dx3, 3)])) < dptol ))
        call check(error, all(abs(moment(dx3, order, 3, mask=(dx3 < 45)) -&
                     reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                              224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                              1694._dp/9., 36._dp&
                               ], [size(dx3,1), size(dx3,2)] ))&
                     < dptol ))
    end subroutine

    subroutine test_int32_dim1_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i1, order)) < dptol)
        call check(error, abs(moment(i1, order, dim=1)) < dptol)
    end subroutine

    subroutine test_int32_dim1_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(i1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(i1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_int32_dim1_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i1, order, mask=(i1 < 5))) < dptol)
        call check(error, abs(moment(i1, order, 1, mask=(i1 < 5))) < dptol)
    end subroutine

    subroutine test_int32_dim2_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i2, order)) < dptol)
        call check(error, all(abs(moment(i2, order, 1)) < dptol))
        call check(error, all(abs(moment(i2, order, 2)) < dptol))
    end subroutine

    subroutine test_int32_dim2_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(i2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_int32_dim2_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i2, order, mask=(i2 < 11))) < dptol)
        call check(error, all(abs(moment(i2, order, 1, mask=(i2 < 11))) < dptol))
        call check(error, all(abs(moment(i2, order, 2, mask=(i2 < 11))) < dptol))
    end subroutine

    subroutine test_int32_dim3_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i3, order)) < dptol)
        call check(error, all(abs(moment(i3, order, 1)) < dptol))
        call check(error, all(abs(moment(i3, order, 2)) < dptol))
        call check(error, all(abs(moment(i3, order, 3)) < dptol))
    end subroutine

    subroutine test_int32_dim3_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(i3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(i3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_int32_dim3_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(i3, order, mask=(i3 < 11)) ) < dptol)
        call check(error, all(abs(moment(i3, order, 1, mask=(i3 < 45))) < dptol ))
        call check(error, all(abs(moment(i3, order, 2, mask=(i3 < 45))) < dptol ))
        call check(error, all(abs(moment(i3, order, 3, mask=(i3 < 45))) < dptol ))
    end subroutine

    subroutine test_int32_dim1_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i1, order) - 2._dp) < dptol)
        call check(error, abs(moment(i1, order, dim=1) - 2._dp) < dptol)
    end subroutine

    subroutine test_int32_dim1_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(i1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(i1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_int32_dim1_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i1, order, mask=(i1 < 5)) - 1.25_dp) < dptol)
        call check(error, abs(moment(i1, order, 1, mask=(i1 < 5)) - 1.25_dp) < dptol)
    end subroutine

    subroutine test_int32_dim2_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i2, order) - 107.25_dp/9.) < dptol)
        call check(error, all(abs(moment(i2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
        call check(error, all(abs(moment(i2, order, 2) -&
                      [19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
    end subroutine

    subroutine test_int32_dim2_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(i2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_int32_dim2_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i2, order, mask=(i2 < 11))- 2.75_dp*3.) < dptol)
        call check(error, all(abs(moment(i2, order, 1, mask=(i2 < 11)) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
        call check(error, all(abs(moment(i2, order, 2, mask=(i2 < 11)) -&
                      [19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
    end subroutine

    subroutine test_int32_dim3_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i3, order) - 153.4_dp*35./36.) < dptol)
        call check(error, all(abs(moment(i3, order, 1) -&
                 reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
                          4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
                          16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
                          [size(i3,2), size(i3,3)])*3._dp/4.)&
                 < dptol))
        call check(error, all(abs(moment(i3, order, 2) -&
                 reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
                          [size(i3,1), size(i3,3)] )*2._dp/3.)&
                 < dptol))
        call check(error, all(abs(moment(i3, order, 3) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(i3,1), size(i3,2)] )*2./3.)&
                 < dptol))
    end subroutine

    subroutine test_int32_dim3_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(i3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(i3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(i3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_int32_dim3_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(i3, order, mask=(i3 < 11)) -&
                          7.7370242214532876_dp ) < dptol)
        call check(error, all(abs(moment(i3, order, 1, mask=(i3 < 45)) -&
                      reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                               80._dp, 80._dp, 32._dp/3.],&
                               [size(i3, 2), size(i3, 3)])) < dptol ))
        call check(error, all(abs(moment(i3, order, 2, mask=(i3 < 45)) -&
                      reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                                344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                                1376._dp/9., 992._dp/9., 4._dp&
                               ],&
                      [size(i3, 1), size(i3, 3)])) < dptol ))
        call check(error, all(abs(moment(i3, order, 3, mask=(i3 < 45)) -&
                     reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                              224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                              1694._dp/9., 36._dp&
                               ], [size(i3,1), size(i3,2)] ))&
                     < dptol ))
    end subroutine

    subroutine test_int64_dim1_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di1, order)) < dptol)
        call check(error, abs(moment(di1, order, dim=1)) < dptol)
    end subroutine

    subroutine test_int64_dim1_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(di1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(di1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_int64_dim1_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di1, order, mask=(di1 < 5))) < dptol)
        call check(error, abs(moment(di1, order, 1, mask=(di1 < 5))) < dptol)
    end subroutine

    subroutine test_int64_dim2_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di2, order)) < dptol)
        call check(error, all(abs(moment(di2, order, 1)) < dptol))
        call check(error, all(abs(moment(di2, order, 2)) < dptol))
    end subroutine

    subroutine test_int64_dim2_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(di2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(di2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_int64_dim2_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di2, order, mask=(di2 < 11))) < dptol)
        call check(error, all(abs(moment(di2, order, 1, mask=(di2 < 11))) < dptol))
        call check(error, all(abs(moment(di2, order, 2, mask=(di2 < 11))) < dptol))
    end subroutine

    subroutine test_int64_dim3_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di3, order)) < dptol)
        call check(error, all(abs(moment(di3, order, 1)) < dptol))
        call check(error, all(abs(moment(di3, order, 2)) < dptol))
        call check(error, all(abs(moment(di3, order, 3)) < dptol))
    end subroutine

    subroutine test_int64_dim3_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(moment(di3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(di3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_int64_dim3_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(di3, order, mask=(di3 < 11)) ) < dptol)
        call check(error, all(abs(moment(di3, order, 1, mask=(di3 < 45))) < dptol ))
        call check(error, all(abs(moment(di3, order, 2, mask=(di3 < 45))) < dptol ))
        call check(error, all(abs(moment(di3, order, 3, mask=(di3 < 45))) < dptol ))
    end subroutine

    subroutine test_int64_dim1_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di1, order) - 2._dp) < dptol)
        call check(error, abs(moment(di1, order, dim=1) - 2._dp) < dptol)
    end subroutine

    subroutine test_int64_dim1_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(di1, order, mask=.false.)))
        call check(error, ieee_is_nan(moment(di1, order, 1, mask=.false.)))
    end subroutine

    subroutine test_int64_dim1_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di1, order, mask=(di1 < 5)) - 1.25_dp) < dptol)
        call check(error, abs(moment(di1, order, 1, mask=(di1 < 5)) - 1.25_dp) < dptol)
    end subroutine

    subroutine test_int64_dim2_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di2, order) - 107.25_dp/9.) < dptol)
        call check(error, all(abs(moment(di2, order, 1) - [5._dp, 5._dp, 1.25_dp]) < dptol))
        call check(error, all(abs(moment(di2, order, 2) -&
                      [19._dp, 43._dp / 3., 31._dp / 3. , 7._dp]*2._dp/3.) < dptol))
    end subroutine

    subroutine test_int64_dim2_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(i2, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(di2, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di2, order, 2, mask=.false.))))
    end subroutine

    subroutine test_int64_dim2_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di2, order, mask=(di2 < 11))- 2.75_dp*3.) < dptol)
        call check(error, all(abs(moment(di2, order, 1, mask=(di2 < 11)) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
        call check(error, all(abs(moment(di2, order, 2, mask=(di2 < 11)) -&
                      [19._dp*2./3., 43._dp/9.*2., 0.25_dp , 0.25_dp]) < dptol))
    end subroutine

    subroutine test_int64_dim3_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di3, order) - 153.4_dp*35./36.) < dptol)
        call check(error, all(abs(moment(di3, order, 1) -&
                 reshape([20._dp / 3., 20._dp / 3., 5._dp / 3.,&
                          4* 20._dp / 3., 4* 20._dp / 3., 4* 5._dp / 3.,&
                          16* 20._dp / 3., 16* 20._dp / 3., 16* 5._dp / 3.],&
                          [size(di3,2), size(di3,3)])*3._dp/4.)&
                 < dptol))
        call check(error, all(abs(moment(di3, order, 2) -&
                 reshape([19._dp, 43._dp / 3., 31._dp / 3. , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3., 4* 31._dp / 3. , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3., 16* 31._dp / 3. , 16* 7.0_dp],&
                          [size(di3,1), size(di3,3)] )*2._dp/3.)&
                 < dptol))
        call check(error, all(abs(moment(di3, order, 3) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(di3,1), size(di3,2)] )*2./3.)&
                 < dptol))
    end subroutine

    subroutine test_int64_dim3_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(moment(di3, order, mask=.false.)))
        call check(error, any(ieee_is_nan(moment(di3, order, 1, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di3, order, 2, mask=.false.))))
        call check(error, any(ieee_is_nan(moment(di3, order, 3, mask=.false.))))
    end subroutine

    subroutine test_int64_dim3_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(di3, order, mask=(di3 < 11)) -&
                          7.7370242214532876_dp ) < dptol)
        call check(error, all(abs(moment(di3, order, 1, mask=(di3 < 45)) -&
                      reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                               80._dp, 80._dp, 32._dp/3.],&
                               [size(di3, 2), size(di3, 3)])) < dptol ))
        call check(error, all(abs(moment(di3, order, 2, mask=(di3 < 45)) -&
                      reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                                344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                                1376._dp/9., 992._dp/9., 4._dp&
                               ],&
                      [size(i3, 1), size(i3, 3)])) < dptol ))
        call check(error, all(abs(moment(di3, order, 3, mask=(di3 < 45)) -&
                     reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                              224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                              1694._dp/9., 36._dp&
                               ], [size(di3,1), size(di3,2)] ))&
                     < dptol ))
    end subroutine

    subroutine test_csp_dim1_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(c1, order)) < sptol)
        call check(error, abs(moment(c1, order, dim=1)) < sptol)
    end subroutine

    subroutine test_csp_dim1_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(abs(moment(c1, order, mask=.false.))))
        call check(error, ieee_is_nan(abs(moment(c1, order, 1, mask=.false.))))
    end subroutine

    subroutine test_csp_dim1_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(c1, order, mask=(aimag(c1) == 0))) < sptol)
        call check(error, abs(moment(c1, order, 1, mask=(aimag(c1) == 0))) < sptol)
    end subroutine

    subroutine test_csp_dim2_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(c2, order)) < sptol)
        call check(error, all(abs(moment(c2, order, 1)) < sptol))
        call check(error, all(abs(moment(c2, order, 2)) < sptol))
    end subroutine

    subroutine test_csp_dim2_mask_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, ieee_is_nan(abs(moment(c2, order, mask=.false.))))
        call check(error, any(ieee_is_nan(abs(moment(c2, order, 1, mask=.false.)))))
        call check(error, any(ieee_is_nan(abs(moment(c2, order, 2, mask=.false.)))))
    end subroutine

    subroutine test_csp_dim2_mask_array_order1(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 1
        call check(error, abs(moment(c2, order, mask=(aimag(c2) == 0))) < sptol)
        call check(error, all(abs(moment(c2, order, 1, mask=(aimag(c2) == 0))) < sptol))
        call check(error, any(ieee_is_nan( abs(moment(c2, order, 2,&
                          mask=(aimag(c2) == 0))))))
    end subroutine

    subroutine test_csp_dim1_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(c1, order) - (-6.459422410E-02,-0.556084037)) < sptol)
        call check(error, abs(moment(c1, order, dim=1) -&
                        (-6.459422410E-02,-0.556084037)) < sptol)
    end subroutine

    subroutine test_csp_dim1_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(abs(moment(c1, order, mask=.false.))))
        call check(error, ieee_is_nan(abs(moment(c1, order, 1, mask=.false.))))
    end subroutine

    subroutine test_csp_dim1_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(c1, order, mask=(aimag(c1) == 0)) -&
                          (8.969944715E-02,0.00000000)) < sptol)
        call check(error, abs(moment(c1, order, 1, mask=(aimag(c1) == 0)) -&
                          (8.969944715E-02,0.00000000)) < sptol)
    end subroutine

    subroutine test_csp_dim2_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(c2, order) - (-0.163121477,-1.86906016)) < sptol)
        call check(error, all(abs(moment(c2, order, 1) -&
                     [(-6.459422410E-02,-0.556084037),&
                      (-0.581347823,-5.00475645),&
                      (-0.145336956,-1.25118911)]&
                     ) < sptol))
        call check(error, all(abs(moment(c2, order, 2) -&
                     [(0.240498722,0.00000000),&
                     (-1.49895227,0.00000000),&
                     (1.15390968,0.00000000),&
                     (-0.569927275,0.00000000),&
                     (0.944405317,0.00000000)]&
                     ) < sptol))
    end subroutine

    subroutine test_csp_dim2_mask_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, ieee_is_nan(abs(moment(c2, order, mask=.false.))))
        call check(error, any(ieee_is_nan(abs(moment(c2, order, 1, mask=.false.)))))
        call check(error, any(ieee_is_nan(abs(moment(c2, order, 2, mask=.false.)))))
    end subroutine

    subroutine test_csp_dim2_mask_array_order2(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer, parameter :: order = 2
        call check(error, abs(moment(c2, order, mask=(aimag(c2) == 0))-&
                     (1.08109438,0.00000000)) < sptol)
        call check(error, all(abs(moment(c2, order, 1, mask=(aimag(c2)==0)) -&
                      [(8.969944715E-02,0.00000000),&
                       (0.807295084,0.00000000),&
                       (0.201823771,0.00000000)]&
                       ) < sptol))
    end subroutine

end module test_moment

program tester

    use, intrinsic :: iso_fortran_env, only: error_unit
    use testdrive, only: run_testsuite, new_testsuite, testsuite_type
    use test_moment, only: collect_moment, initialize_test_data
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("moment", collect_moment) &
        ]

    call initialize_test_data()

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if

end program tester