! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------

Module CubatureRule_Cn

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE

PUBLIC  :: Rule_Cn
PRIVATE :: Rule_Deg7, Rule_Deg9, SymCub_Sum

CONTAINS
  SUBROUTINE Rule_Cn(KEY,N,VERTEX,INFOLD,VOLUME,NF,Integrand,BASVAL,RGNERR,NUM)
!
!***BEGIN PROLOGUE Rule_Cn
!***DATE WRITTEN   990701   (YYMMDD)
!***REVISION DATE  000814   (Handling of KEY now similar to Tn; changed by RC)
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!
!***REVISION DATE  150729   (YYMMDD) (Made threadsafe / re-entrant)
!***MODIFIER
!          Pat Scott, Dept. of Physics, Imperial College London
!          Email: p.scott@imperial
!
!***PURPOSE  To compute basic integration rule values and
!            corresponding error estimates.
!***DESCRIPTION Rule_Cn7computes basic integration rule values
!            for a vector of integrands over a dim hyperrectangle
!            Rule_Cn7 also computes estimates for the errors by
!            using several null rule approximations.
!            We use a degree 7 integration rule,
!            two degree 5 null rules, one degree 3 null rule and one
!            degree 1 null rule for the hypercube.
!            RESTRICTION : this routine will only give correct results
!            for dim > 2.
!   ON ENTRY
!
!   KEY       Integer.
!             If Key > 2 and Key < 5 then a rule of degree 2*Key + 1
!             is used; otherwise a default rule of degree 7 is used.
!   N         Integer, dimension of the integration problem
!   VERTEX    Real array of dimension (N,0:N).
!             The coordinates of the vertices of the parallelepiped.
!              vertex i -> ( vertex(1,i),vertex(2,i),...,vertex(N,i) )
!   NF        Integer, number of components of the vector integrand.
!   Integrand Real vector function of length NF for computing components of
!              the integrand at X.
!              It must have parameters ( NF, X ); see interface below
!               Input parameters:
!                 X      Real array of length N, the evaluation point.
!                 NF     Integer number of components of Integrand.
!
!   ON RETURN
!
!   BASVAL Real array of dimension NF.
!          The values for the basic rule for each component
!          of the integrand.
!   RGNERR Real array of dimension NF.
!          The error estimates for each component of the integrand.
!   NUM    Integer, number of function evaluations used.
!
!***REFERENCES A. Genz and A. Malik,
!             "An Imbedded Family of Fully Symmetric Numerical
!              Integration Rules",
!              SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED
!                   Integrand, SymCub_Sum, Rule_Deg7, Rule_Deg9
!***END PROLOGUE Rule_Cn
!
   INTEGER,                          INTENT(IN)    :: KEY, N, NF
   INTEGER,                          INTENT(OUT)   :: NUM
   INTEGER, DIMENSION(:),            INTENT(INOUT) :: INFOLD
   REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN)    :: VERTEX
   REAL(KIND=STND), DIMENSION(:),    INTENT(OUT)   :: RGNERR, BASVAL
   REAL(KIND=STND),                  INTENT(IN)    :: VOLUME
   INTERFACE
      FUNCTION INTEGRAND(NF,X) RESULT(VALUE)
         USE PRECISION_MODEL
         INTEGER,                       INTENT(IN) :: NF
         REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: X
         REAL(KIND=STND), DIMENSION(NF)            :: VALUE
      END FUNCTION INTEGRAND
   END INTERFACE
!
   INTEGER, PARAMETER                        :: MXW = 9, MXG = 4, RLS = 5
   REAL(KIND=STND), DIMENSION(MXW,RLS), SAVE :: W
   REAL(KIND=STND), DIMENSION(MXG,MXW), SAVE :: G
   INTEGER,                             SAVE :: OLDKEY = -1, OLDN = 0
   INTEGER,                             SAVE :: WTS, NUMR
!$omp threadprivate(W, G, OLDKEY, OLDN, WTS, NUMR)
!
   INTEGER                                   :: I, DIVAXN
   REAL(KIND=STND), PARAMETER                :: ONE = 1
   REAL(KIND=STND), PARAMETER                :: SMALL = 100*EPSILON(ONE)
   REAL(KIND=STND), DIMENSION(N)             :: CENTER, DFS, GTEMP
   REAL(KIND=STND), DIMENSION(N,N)           :: VERDIF
   REAL(KIND=STND), DIMENSION(NF,RLS)        :: RULE
   REAL(KIND=STND), DIMENSION(NF,3)          :: TEMP
   REAL(KIND=STND), DIMENSION(NF)            :: FRTHDF
   REAL(KIND=STND)                           :: RATIO
!
   IF ( KEY /= OLDKEY .OR. OLDKEY == -1 .OR. N /= OLDN ) THEN
      OLDKEY = KEY
      OLDN = N
      SELECT CASE ( KEY )
      CASE (4)
         CALL Rule_Deg9( N, W, G, WTS, NUMR )
      CASE DEFAULT
         CALL Rule_Deg7( N, W, G, WTS, NUMR )
      END SELECT
   END IF
   NUM = NUMR
   VERDIF = ( VERTEX(:,1:N) - SPREAD( VERTEX(:,0), 2, N ) )/2
   CENTER = VERTEX(:,0) + SUM( VERDIF, 2 )
   DIVAXN = SUM( MAXLOC( SUM( ABS( VERDIF ), 1 ) ) )
   TEMP(:,1) = INTEGRAND( NF, CENTER )
   RULE = MATMUL( TEMP(:,1:1), W(1:1,1:RLS)  )
   RATIO = ( G(1,3)/G(1,2) )**2
   DO I = 1, N
      TEMP(:,2) = INTEGRAND( NF, CENTER - G(1,2)*VERDIF(:,I) )               &
                + INTEGRAND( NF, CENTER + G(1,2)*VERDIF(:,I) )
      TEMP(:,3) = INTEGRAND( NF, CENTER - G(1,3)*VERDIF(:,I) )               &
                + INTEGRAND( NF, CENTER + G(1,3)*VERDIF(:,I) )
      RULE = RULE + MATMUL( TEMP(:,2:3), W(2:3,1:RLS) )
      FRTHDF = ABS( 2*(1-RATIO)*TEMP(:,1) + RATIO*TEMP(:,2) - TEMP(:,3) )/4
      DFS(I) = SUM( FRTHDF, MASK = ABS(TEMP(:,1)) + FRTHDF > ABS(TEMP(:,1)) )
   END DO
   IF ( MAXVAL( DFS ) > 0 ) THEN
      DIVAXN = SUM( MAXLOC( DFS ) )
   END IF
   INFOLD(4) = DIVAXN
!
!    Finish computing the rule values.
!
   DO I = 4, WTS
      GTEMP( 1 : MIN(N,MXG-1) ) = G( 1 : MIN(N,MXG-1) , I )
      IF ( N >= MXG ) THEN
         GTEMP(MXG:N) = G(MXG,I)
      END IF
      TEMP(:,1) = SymCub_Sum( N, VERTEX, GTEMP, NF, INTEGRAND )
      RULE = RULE + MATMUL( TEMP(:,1:1), W(I:I,1:RLS) )
   END DO
!
!    Compute errors.
!
      RULE(:,2:5) = ABS( RULE(:,2:5) )
      RULE(:,3) = MAX( RULE(:,2), RULE(:,3) )
      RULE(:,2) = ABS( RULE(:,1) )
      DO I = 3, 5
         WHERE ( RULE(:,2) + RULE(:,I)/NUM <= RULE(:,2) )
            RULE(:,I) = 0
         END WHERE
      END DO
      RATIO = 5 + 8*KEY
      WHERE ( RATIO*RULE(:,3) <= RULE(:,4) .AND. RATIO*RULE(:,4) <= RULE(:,5) )
          RGNERR = VOLUME*RULE(:,3)/2
      ELSEWHERE
          RGNERR = VOLUME*MAXVAL( RULE(:,3:5), 2 )
      END WHERE
      BASVAL = VOLUME*RULE(:,1)
!
END SUBROUTINE Rule_Cn
!
SUBROUTINE Rule_Deg7( N, W, G, WTSR, NUMR )
!
!***BEGIN PROLOGUE Rule_Deg7
!***KEYWORDS basic integration rule, degree 7
!***PURPOSE  To initialize a degree 7 basic rule, and null rules.
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!
!***DATE WRITTEN  990701   (YYMMDD)
!***DESCRIPTION  Rule_Deg7 initializes a degree 7 integration rule,
!            two degree 5 null rules, one degree 3 null rule and one
!            degree 1 null rule for the hypercube [-1,1]**N.
!
!   ON ENTRY
!
!   N      Integer, number of variables.
!
!   ON RETURN
!   W      Real array of dimension (WTS,5).
!          The weights for the basic and null rules.
!          W(1,1),...,W(WTS,1) are weights for the basic rule.
!          W(I,1),...,W(WTS,I), for I > 1 are null rule weights.
!   G      Real array of dimension (N, WTS).
!          The fully symmetric sum generators for the rules.
!          G(1, J), ..., G(N, J) are the are the generators for the
!          points associated with the Jth weights.
!   WTSR   Integer, WTS
!   NUMR   Integer, number of points for Rule_Deg7
!
!***REFERENCES A. Genz and A. Malik,
!             "An Imbedded Family of Fully Symmetric Numerical
!              Integration Rules",
!              SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED-NONE
!***END PROLOGUE Rule_Deg7
!
!   Global variables
!
!   WTS Integer, PARAMETER.
!          The number of weights in each of the rules : 6
!
      INTEGER,                         INTENT(IN)  :: N
      REAL(KIND=STND), DIMENSION(:,:), INTENT(OUT) :: W, G
      INTEGER,                         INTENT(OUT) :: WTSR, NUMR
!
!   Constant, the size of RULPTS
!
      INTEGER, PARAMETER              :: WTS = 6
!
!   Local Variables
!
      INTEGER                         :: K
      REAL(KIND=STND)                 :: TEMP, LAM0, LAM1, LAM2, LAMP, TWONDM
      REAL(KIND=STND), DIMENSION(WTS) :: RULPTS
      REAL(KIND=STND), DIMENSION(3)   :: ALPHA
!
!     Initialize generators, weights and RULPTS
!
      G = 0
      W = 0
      TWONDM = 2**N
      RULPTS(1) = 1
      RULPTS(2:WTS-2) = 2*N
      RULPTS(WTS-1) = 2*N*(N-1)
      RULPTS(WTS) = TWONDM
!
!     Compute squared generator parameters
!
      LAM0 = 0.4707_STND
      LAMP = 0.5625_STND
      LAM1 = 4/( 15 - 5/LAM0 )
      TEMP = (1 - LAM1/LAM0 )/27
      LAM2 = ( 5 - 7*LAM1 - 35*TEMP )/( 7 - 35*LAM1/3 - 35*TEMP/LAM0 )
!
!     Compute degree 7 rule weights
!
      W(6,1) = 1/(3*LAM0)**3/TWONDM
      W(5,1) = ( 1 - 5*LAM0/3 )/( 60*(LAM1-LAM0)*LAM1**2 )
      W(3,1) = ( 1 - 5*LAM2/3 - 5*TWONDM*W(6,1)*LAM0*(LAM0-LAM2) )          &
              /( 10*LAM1*(LAM1-LAM2) ) - 2*(N-1)*W(5,1)
      W(2,1) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,1)*LAM0*(LAM0-LAM1) )          &
              /( 10*LAM2*(LAM2-LAM1) )
!
!     Compute weights for 2 degree 5, 1 degree 3 and 1 degree 1 rules
!
      W(6,2) = 1/( 36*LAM0**3 )/TWONDM
      W(5,2) = ( 1 - 9*TWONDM*W(6,2)*LAM0**2 )/( 36*LAM1**2 )
      W(3,2) = ( 1 - 5*LAM2/3 - 5*TWONDM*W(6,2)*LAM0*(LAM0-LAM2) )          &
              /( 10*LAM1* (LAM1-LAM2) ) - 2* (N-1)*W(5,2)
      W(2,2) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,2)*LAM0*(LAM0-LAM1) )          &
              /( 10*LAM2* (LAM2-LAM1) )
      W(6,3) = 5/(108*LAM0**3)/TWONDM
      W(5,3) = ( 1 - 9*TWONDM*W(6,3)*LAM0**2 )/( 36*LAM1**2 )
      W(4,3) = ( 1 - 5*LAM1/3 - 5*TWONDM*W(6,3)*LAM0*(LAM0-LAM1) )          &
              /( 10*LAMP*(LAMP-LAM1) )
      W(3,3) = ( 1 - 5*LAMP/3 - 5*TWONDM*W(6,3)*LAM0* (LAM0-LAMP) )         &
              /( 10*LAM1*(LAM1-LAMP) ) - 2*(N-1)*W(5,3)
      W(6,4) = 1/( 54*LAM0**3 )/TWONDM
      W(5,4) = ( 1 - 18*TWONDM*W(6,4)*LAM0**2 )/( 72*LAM1**2 )
      W(3,4) = ( 1 - 10*LAM2/3 - 10*TWONDM*W(6,4)*LAM0*(LAM0-LAM2) )        &
              /( 20*LAM1*(LAM1-LAM2) ) - 2*(N-1)*W(5,4)
      W(2,4) = ( 1 - 10*LAM1/3 - 10*TWONDM*W(6,4)*LAM0*(LAM0-LAM1) )        &
              /( 20*LAM2*(LAM2-LAM1) )
!
!     Set generator values
!
      LAM0 = SQRT(LAM0)
      LAM1 = SQRT(LAM1)
      LAM2 = SQRT(LAM2)
      LAMP = SQRT(LAMP)
      G(  :,6) = LAM0
      G(1:2,5) = LAM1
      G(  1,2) = LAM2
      G(  1,3) = LAM1
      G(  1,4) = LAMP
!
!     Compute constant weight values.
!
      W(1,1:5) = 1 - MATMUL( RULPTS(2:WTS), W(2:WTS,1:5) )
!
!     Compute final weight values; null rule weights are computed as
!     differences between weights from highest degree and lower degree rules.
!
      W(1:WTS,2:5) = W(1:WTS,2:5) - SPREAD( W(1:WTS,1), 2, 4 )
!
!        Orthogonalize and normalize null rules.
!
      TEMP = SUM( RULPTS*W(1:WTS,1)*W(1:WTS,1) )
      W(1:WTS,2) = W(1:WTS,2)*SQRT( TEMP/SUM( RULPTS*W(1:WTS,2)*W(1:WTS,2) ) )
      DO K = 3, 5
         ALPHA(1:K-2) = -MATMUL( TRANSPOSE(W(1:WTS,2:K-1)), RULPTS*W(1:WTS,K) )
         W(1:WTS,K) = W(1:WTS,K) + MATMUL( W(1:WTS,2:K-1), ALPHA(1:K-2) )/TEMP
         W(1:WTS,K) = W(1:WTS,K)*SQRT(TEMP/SUM(RULPTS*W(1:WTS,K)*W(1:WTS,K)))
      END DO
      WTSR = WTS
      NUMR = SUM( RULPTS )
!
END SUBROUTINE Rule_Deg7
!
SUBROUTINE Rule_Deg9( N, W, G, WTSR, NUMR )
!***BEGIN PROLOGUE Rule_Deg9
!***KEYWORDS basic integration rule, degree 9
!***PURPOSE  To initialize a degree 9 basic rule and null rules.
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!
!***DATE WRITTEN  990701   (YYMMDD)
!***DESCRIPTION  Rule_Deg9 initializes a degree 9 integration rule,
!            two degree 7 null rules, one degree 5 null rule and one
!            degree 3 null rule for the hypercube [-1,1]**N.
!
!   ON ENTRY
!
!   N      Integer, number of variables.
!
!   ON RETURN
!   W      Real array of dimension (WTS,5).
!          The weights for the basic and null rules.
!          W(1,1),...,W(WTS,1) are weights for the basic rule.
!          W(I,1),...,W(WTS,I), for I > 1 are null rule weights.
!   G      Real array of dimension (N, WTS).
!          The fully symmetric sum generators for the rules.
!          G(1, J), ..., G(N, J) are the are the generators for the
!          points associated with the Jth weights.
!   WTSR   Integer, WTS
!   NUMR   Integer, number of points for Rule_Deg7
!
!***REFERENCES A. Genz and A. Malik,
!             "An Imbedded Family of Fully Symmetric Numerical
!              Integration Rules",
!              SIAM J Numer. Anal. 20 (1983), pp. 580-588.
!***ROUTINES CALLED-NONE
!***END PROLOGUE Rule_Deg9
!
!   Global variables
!
      INTEGER,                         INTENT(IN)  :: N
      REAL(KIND=STND), DIMENSION(:,:), INTENT(OUT) :: W, G
      INTEGER,                         INTENT(OUT) :: WTSR, NUMR
!
      INTEGER, PARAMETER              :: WTS = 9
!
!   Local Variables
!
      INTEGER                         :: K
      REAL(KIND=STND), DIMENSION(WTS) :: RULPTS
      REAL(KIND=STND), DIMENSION(3)   :: ALPHA
      REAL(KIND=STND)                 :: TEMP, LAM0,LAM1,LAM2,LAM3,LAMP, TWONDM
!
!***FIRST EXECUTABLE STATEMENT Rule_Deg9
!
!     Initialize generators, weights and RULPTS
!
      G = 0
      W = 0
      TWONDM = 2**N
      RULPTS(1) = 1
      RULPTS(2:5) = 2*N
      RULPTS(6) = 2*N*(N-1)
      RULPTS(7) = 4*N*(N-1)
      RULPTS(8) = (4*N*(N-1)*(N-2))/3
      RULPTS(9) = TWONDM
!
!     Compute squared generator parameters
!
      LAM0 = 0.4707_STND
      LAMP = 0.0625_STND
      LAM1 = 4/( 15 - 5/LAM0 )
      TEMP = ( 1 - LAM1/LAM0 )/27
      LAM2 = ( 5 - 7*LAM1 - 35*TEMP )/( 7 - 35*LAM1/3 - 35*TEMP/LAM0 )
      TEMP = TEMP*( 1 - LAM2/LAM0 )/3
      LAM3 = ( 7  - 9*(LAM2+LAM1)   + 63*LAM2*LAM1/5 - 63*TEMP )              &
            /( 9 - 63*(LAM2+LAM1)/5 + 21*LAM2*LAM1 - 63*TEMP/LAM0 )
!
!     Compute degree 9 rule weights
!
      W(9,1) = 1/(3*LAM0)**4/TWONDM
      W(8,1) = ( 1 - 1/(3*LAM0) )/(6*LAM1)**3
      W(7,1) = ( 1 - 7*(LAM0+LAM1)/5 + 7*LAM0*LAM1/3 )                        &
              /( 84*LAM1*LAM2*(LAM2-LAM0)*(LAM2-LAM1) )
      W(6,1) = ( 1 - 7*(LAM0+LAM2)/5 + 7*LAM0*LAM2/3 )                        &
              /( 84*LAM1*LAM1*(LAM1-LAM0)*(LAM1-LAM2) )                       &
              - W(7,1)*LAM2/LAM1 - 2*(N-2)*W(8,1)
      W(4,1) = ( 1 - 9*( (LAM0+LAM1+LAM2)/7                                   &
                       - (LAM0*LAM1+LAM0*LAM2+LAM1*LAM2)/5 )                  &
                   - 3*LAM0*LAM1*LAM2 )                                       &
              /( 18*LAM3*(LAM3-LAM0)*(LAM3-LAM1)*(LAM3-LAM2) )
      W(3,1) = ( 1 - 9*( (LAM0+LAM1+LAM3)/7                                   &
                       - (LAM0*LAM1+LAM0*LAM3+LAM1*LAM3)/5 )                  &
                    -3*LAM0*LAM1*LAM3 )                                       &
              /( 18*LAM2*(LAM2-LAM0)*(LAM2-LAM1)*(LAM2-LAM3) )                &
              - 2*(N-1)*W(7,1)
      W(2,1) = ( 1 - 9*( (LAM0+LAM2+LAM3)/7                                   &
                       - (LAM0*LAM2+LAM0*LAM3+LAM2*LAM3)/5 )                  &
                   - 3*LAM0*LAM2*LAM3 )                                       &
              /( 18*LAM1*(LAM1-LAM0)*(LAM1-LAM2)*(LAM1-LAM3) )                &
              - 2*(N-1)*( W(6,1) + W(7,1) + (N-2)*W(8,1) )
!
!     Compute weights for 2 degree 7, 1 degree 5 and 1 degree 3 rules
!
      W(9,2) = 1/( 108*LAM0**4 )/TWONDM
      W(8,2) = ( 1 - 27*TWONDM*W(9,2)*LAM0**3 )/(6*LAM1)**3
      W(7,2) = ( 1 - 5*LAM1/3 - 15*TWONDM*W(9,2)*LAM0**2*(LAM0-LAM1) )        &
              /( 60*LAM1*LAM2*(LAM2-LAM1) )
      W(6,2) = ( 1 - 9*( 8*LAM1*LAM2*W(7,2) + TWONDM*W(9,2)*LAM0**2 ) )       &
              /(36*LAM1*LAM1) - 2*W(8,2)*(N-2)
      W(4,2) = ( 1 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3                          &
                       + TWONDM*W(9,2)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) )       &
              /( 14*LAM3*(LAM3-LAM1)*(LAM3-LAM2) )
      W(3,2) = ( 1 - 7*( (LAM1+LAM3)/5 - LAM1*LAM3/3                          &
                       + TWONDM*W(9,2)*LAM0*(LAM0-LAM1)*(LAM0-LAM3) ) )       &
              /( 14*LAM2*(LAM2-LAM1)*(LAM2-LAM3) ) - 2*(N-1)*W(7,2)
      W(2,2) = ( 1 - 7*( (LAM2+LAM3)/5 - LAM2*LAM3/3                          &
                       + TWONDM*W(9,2)*LAM0*(LAM0-LAM2)*(LAM0-LAM3) ) )       &
              /( 14*LAM1*(LAM1-LAM2)*(LAM1-LAM3) )                            &
              - 2*(N-1)*( W(6,2) + W(7,2) + (N-2)*W(8,2) )
      W(9,3) = 5/( 324*LAM0**4 )/TWONDM
      W(8,3) = ( 1 - 27*TWONDM*W(9,3)*LAM0**3 )/(6*LAM1)**3
      W(7,3) = ( 1 - 5*LAM1/3 - 15*TWONDM*W(9,3)*LAM0**2*(LAM0-LAM1) )        &
              /( 60*LAM1*LAM2* (LAM2-LAM1) )
      W(6,3) = ( 1 - 9*( 8*LAM1*LAM2*W(7,3) + TWONDM*W(9,3)*LAM0**2 ) )       &
              /( 36*LAM1*LAM1) - 2*W(8,3)*(N-2)
      W(5,3) = ( 1 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3                          &
                       + TWONDM*W(9,3)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) )       &
              /( 14*LAMP* (LAMP-LAM1)*(LAMP-LAM2) )
      W(3,3) = ( 1 - 7*( (LAM1+LAMP)/5 - LAM1*LAMP/3                          &
                       + TWONDM*W(9,3)*LAM0*(LAM0-LAM1)*(LAM0-LAMP) ) )       &
              /( 14*LAM2*(LAM2-LAM1)*(LAM2-LAMP) ) - 2*(N-1)*W(7,3)
      W(2,3) = ( 1 - 7*( (LAM2+LAMP)/5 - LAM2*LAMP/3                          &
                       + TWONDM*W(9,3)*LAM0*(LAM0-LAM2)*(LAM0-LAMP) ) )       &
              /( 14*LAM1*(LAM1-LAM2)*(LAM1-LAMP) )                            &
              - 2*(N-1)*( W(6,3) + W(7,3) + (N-2)*W(8,3) )
      W(9,4) = 2/( 81*LAM0**4 )/TWONDM
      W(8,4) = ( 2 - 27*TWONDM*W(9,4)*LAM0**3)/(6*LAM1)**3
      W(7,4) = ( 2 - 15*LAM1/9-15*TWONDM*W(9,4)*LAM0*(LAM0-LAM1) )            &
              /( 60*LAM1*LAM2*(LAM2-LAM1) )
      W(6,4) = ( 1 - 9*( 8*LAM1*LAM2*W(7,4) + TWONDM*W(9,4)*LAM0**2 ) )       &
              /( 36*LAM1*LAM1 ) - 2*W(8,4)*(N-2)
      W(4,4) = ( 2 - 7*( (LAM1+LAM2)/5 - LAM1*LAM2/3                          &
                       + TWONDM*W(9,4)*LAM0*(LAM0-LAM1)*(LAM0-LAM2) ) )       &
              /( 14*LAM3*(LAM3-LAM1)*(LAM3-LAM2) )
      W(3,4) = ( 2 - 7*( (LAM1+LAM3)/5 - LAM1*LAM3/3                          &
                       + TWONDM*W(9,4)*LAM0*(LAM0-LAM1)*(LAM0-LAM3) ) )       &
              /( 14*LAM2*(LAM2-LAM1)*(LAM2-LAM3) ) - 2*(N-1)*W(7,4)
      W(2,4) = ( 2 - 7*( (LAM2+LAM3)/5 - LAM2*LAM3/3                          &
                       + TWONDM*W(9,4)*LAM0*(LAM0-LAM2)*(LAM0-LAM3) ) )       &
              /( 14*LAM1*(LAM1-LAM2)*(LAM1-LAM3) )                            &
              - 2*(N-1)*( W(6,4) + W(7,4) + (N-2)*W(8,4) )
      W(2,5) = 1/( 6*LAM1 )
!
!     Set generator values
!
      LAM0 = SQRT(LAM0)
      LAM1 = SQRT(LAM1)
      LAM2 = SQRT(LAM2)
      LAM3 = SQRT(LAM3)
      LAMP = SQRT(LAMP)
      G(  :,9) = LAM0
      G(1:3,8) = LAM1
      G(  1,7) = LAM1
      G(  2,7) = LAM2
      G(1:2,6) = LAM1
      G(  1,5) = LAMP
      G(  1,4) = LAM3
      G(  1,3) = LAM2
      G(  1,2) = LAM1
!
!     Compute constant weight values.
!
      W(1,1:5) = 1 - MATMUL( RULPTS(2:WTS), W(2:WTS,1:5) )
!
!     Compute final weight values; null rule weights are computed as
!     differences between weights from highest degree and lower degree rules.
!
      W(1:WTS,2:5) = W(1:WTS,2:5) - SPREAD( W(1:WTS,1), 2, 4 )
!
!        Orthogonalize and normalize null rules.
!
      TEMP = SUM( RULPTS*W(1:WTS,1)*W(1:WTS,1) )
      W(1:WTS,2) = W(1:WTS,2)*SQRT( TEMP/SUM( RULPTS*W(1:WTS,2)*W(1:WTS,2) ) )
      DO K = 3, 5
         ALPHA(1:K-2) = -MATMUL( TRANSPOSE(W(1:WTS,2:K-1)), RULPTS*W(1:WTS,K) )
         W(1:WTS,K) = W(1:WTS,K) + MATMUL( W(1:WTS,2:K-1), ALPHA(1:K-2) )/TEMP
         W(1:WTS,K) = W(1:WTS,K)*SQRT(TEMP/SUM(RULPTS*W(1:WTS,K)*W(1:WTS,K)))
      END DO
      WTSR = WTS
      NUMR = SUM( RULPTS )
!
END SUBROUTINE Rule_Deg9
!
!
FUNCTION SymCub_Sum( N, VERTEX, GIN, NF, Integrand ) RESULT(SymCubSum)
!
!***BEGIN PROLOGUE SymCub_Sum
!***KEYWORDS fully symmetric sum
!***PURPOSE  To compute fully symmetric basic rule sums
!***AUTHOR
!
!            Alan Genz
!            Department of Mathematics
!            Washington State University
!            Pullman, WA 99164-3113, USA
!
!***LAST MODIFICATION 99-06
!***DESCRIPTION SymCub_Sum computes a fully symmetric sum for a vector of
!            integrand values over a parallelepiped. The sum is taken over all
!            sign combinations and permutations of the generators for the sum.
!
!   ON ENTRY
!
!   N       Integer, number of variables.
!   VERTEX  Real array of dimension (N,0:N)
!           The vertices of the simplex, one vertex per column.
!   NF      Integer, number of components for the vector integrand.
! Integrand Real vector function of length NF for computing components of
!            the integrand at Z.
!            It must have parameters ( NF, Z ); see interface below
!            Input parameters:
!              Z      Real array of length N, the evaluation point.
!              NF     Integer number of components of Integrand.
!   GIN    Real Array of dimension (1:N).
!          The generators for the fully symmetric sum.

!
!   ON RETURN
!
! SymCub_Sum Real array of length NF, the values for the fully symmetric
!            sums for each component of the integrand.
!
!***ROUTINES CALLED: Integrand
!
!***END PROLOGUE SymCub_Sum
!
!   Global variables.
!
      INTEGER,                          INTENT(IN) :: N, NF
      INTERFACE
         FUNCTION Integrand(NF,Z) RESULT(Value)
            USE Precision_Model
            INTEGER,                       INTENT(IN) :: NF
            REAL(KIND=STND), DIMENSION(:), INTENT(IN) :: Z
            REAL(KIND=STND), DIMENSION(NF)            :: Value
         END FUNCTION Integrand
      END INTERFACE
      REAL(KIND=STND), DIMENSION(:,0:), INTENT(IN) :: VERTEX
      REAL(KIND=STND), DIMENSION(:),    INTENT(IN) :: GIN
      REAL(KIND=STND), DIMENSION(NF)               :: SymCubSum
!
!   Local variables.
!
      INTEGER                         :: IX, JX, I, J
      REAL(KIND=STND), DIMENSION(N,N) :: VERDIF
      REAL(KIND=STND), DIMENSION(N)   :: CENTER, G
      REAL(KIND=STND)                 :: GI, GJ
!
!***FIRST PROCESSING STATEMENT SymCub_Sum
!
      SymCubSum = 0
      G = ABS( GIN )
!
!     Sort input generators if necessary
!
      DO I = 2, N
         IF ( G(I) > G(I-1) ) THEN
            GI = G(I)
            DO J = I-1, 1, -1
               IF ( GI <= G(J) ) THEN
                  EXIT
               END IF
               G(J+1) = G(J)
            END DO
            G(J+1) = GI
         END IF
      END DO
      VERDIF = ( VERTEX(:,1:N) - SPREAD( VERTEX(:,0), 2, N ) )/2
      CENTER = VERTEX(:,0) + SUM( VERDIF, 2 )
!
!     Compute integrand values for sign changes and permutations of G
!
      DO
         DO
            SymCubSum = SymCubSum + Integrand( NF, CENTER + MATMUL(VERDIF,G) )
            DO I = 1, N
                G(I) = - G(I)
                IF ( G(I) < 0 ) THEN
                   EXIT
                END IF
            END DO
            IF ( I > N ) THEN
               EXIT
            END IF
         END DO
!
!        Find next distinct permuation of G and loop back for value.
!        Permutations are generated in reverse lexicographic order.
!
         DO I = 2, N
            IF ( G(I-1) > G(I) ) THEN
               GI = G(I)
               IX = I - 1
               DO J = 1, (I-1)/2
                  GJ = G(J)
                  G(J) = G(I-J)
                  G(I-J) = GJ
                  IF (  GJ <= GI ) THEN
                     IX = IX - 1
                  END IF
                  IF ( G(J) > GI ) THEN
                     JX = J
                  END IF
               END DO
               IF ( G(IX) <= GI ) THEN
                  IX = JX
               END IF
               G(I) = G(IX)
               G(IX) = GI
               EXIT
            END IF
         END DO
         IF ( I > N ) THEN
            EXIT
         END IF
      END DO
!
      END Function SymCub_Sum
!
END Module CubatureRule_Cn


/*
vim:syntax=sml
*/

/* (Heap m) <: (Heap n) iff n <= m */
datatype Heap (min:Int) =
      Empty
    | Node of (x:Int. min <= x) (c:Int) (l:(Heap x)) (r:(Heap x));;

let n1 : (Heap 1) = (Empty 0);; /* BUG: bad arg */
let n2 : (Heap 1) = Node 1 1 6
                       (Node 1 2 2 (Empty 2) (Empty 2))
                       (Node 1 4 2 (Empty 4) (Empty 4));;

let foo (h:(Heap 0)) : Bool = true;;

foo n2;;

let min (a:Int) (b:Int) : (c:Int.(a>=c) && (b>=c)) =
  if[(c:Int.(a>=c) && (b>=c))] (a >= b) then
    b
  else
    a;;

let max = fn (a:Int) (b:Int) =>
  if[c:Int.(c>=a) && (c>=b)] (a >= b) then
    a
  else
    b;;

let heap_children (min:Int) (h:(Heap min)) : Int =
  caseHeap min h Int
    (fn u => 0)
    (fn x c l r => c);;

let rec insert (hmin:Int)
               (h:(Heap hmin))
               (v:Int)
               (rmin:Int.(rmin <= hmin) && (rmin <= v)) :
               (Heap rmin) =
  caseHeap hmin h (Heap rmin)
    (fn u =>
      Node v v 2 (Empty v) (Empty v))
    (fn x c l r =>
      if[Heap rmin] v < x
      then
        let newchildren : Int = (heap_children hmin h) + 1 in
        (Node rmin v newchildren (Node v x c l r) (Empty v))
      else /* v >= x */
        let lchildren : Int = heap_children x l in
        let rchildren : Int = heap_children x r in
        let newmin : (m:Int.(m <= x) && (m <= rmin)) = min x rmin in
        if[Heap rmin] lchildren < rchildren
        then
          Node rmin x (c + 1) (insert x l v x) r
        else
          Node rmin x (c + 1) l (insert x r v x))
;;

let extract_min (min:Int) (h:(Heap min)) : (r:Int.(min <= r)) =
  caseHeap min h (r:Int.(min <= r))
    (fn u => min) /* This seems weird */
    (fn x c l r => x)
;;

let h1 = insert 0 (Empty 0) 1 0;;
let h2 = insert 0 h1 2 0;;
extract_min 0 h2;;


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module inner_product

  use run_nml,     only: nlins,ncols,nlays
  use definitions, only: t_state,t_diag,t_grid,wp

  implicit none

  private

  public :: kinetic_energy

  contains

  subroutine kinetic_energy(state,diag,grid)

    ! This subroutine calculates the specific kinetic energy.

    type(t_state), intent(in)    :: state ! state to use for calculating e_kin
    type(t_diag),  intent(inout) :: diag  ! diagnostic properties (e_kin is a diagnostic property)
    type(t_grid),  intent(in)    :: grid  ! grid properties
    ! local variables
    integer :: ji,jk,jl                   ! loop indices

    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji,jk,jl)
    do ji=1,nlins
      do jk=1,ncols
        do jl=1,nlays
          diag%e_kin(ji,jk,jl) = &
          grid%inner_product_weights(ji,jk,jl,1)*state%wind_u(ji+1,jk+1,jl  )**2 &
          + grid%inner_product_weights(ji,jk,jl,2)*state%wind_v(ji+1,jk+1,jl  )**2 &
          + grid%inner_product_weights(ji,jk,jl,3)*state%wind_u(ji+1,jk  ,jl  )**2 &
          + grid%inner_product_weights(ji,jk,jl,4)*state%wind_v(ji  ,jk+1,jl  )**2 &
          + grid%inner_product_weights(ji,jk,jl,5)*state%wind_w(ji+1,jk+1,jl  )**2 &
          + grid%inner_product_weights(ji,jk,jl,6)*state%wind_w(ji+1,jk+1,jl+1)**2
          diag%e_kin(ji,jk,jl) = 0.5_wp*diag%e_kin(ji,jk,jl)
        enddo
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine kinetic_energy

end module inner_product


      SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V,
     $                   LDV, TAU, WORK, RESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            ITYPE, KBAND, LDA, LDU, LDV, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DSYT21 generally checks a decomposition of the form
*
*     A = U S U'
*
*  where ' means transpose, A is symmetric, U is orthogonal, and S is
*  diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
*
*  If ITYPE=1, then U is represented as a dense matrix; otherwise U is
*  expressed as a product of Householder transformations, whose vectors
*  are stored in the array "V" and whose scaling constants are in "TAU".
*  We shall use the letter "V" to refer to the product of Householder
*  transformations (which should be equal to U).
*
*  Specifically, if ITYPE=1, then:
*
*     RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
*     RESULT(2) = | I - UU' | / ( n ulp )
*
*  If ITYPE=2, then:
*
*     RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
*  If ITYPE=3, then:
*
*     RESULT(1) = | I - VU' | / ( n ulp )
*
*  For ITYPE > 1, the transformation U is expressed as a product
*  V = H(1)...H(n-2),  where H(j) = I  -  tau(j) v(j) v(j)' and each
*  vector v(j) has its first j elements 0 and the remaining n-j elements
*  stored in V(j+1:n,j).
*
*  Arguments
*  =========
*
*  ITYPE   (input) INTEGER
*          Specifies the type of tests to be performed.
*          1: U expressed as a dense orthogonal matrix:
*             RESULT(1) = | A - U S U' | / ( |A| n ulp )   *and*
*             RESULT(2) = | I - UU' | / ( n ulp )
*
*          2: U expressed as a product V of Housholder transformations:
*             RESULT(1) = | A - V S V' | / ( |A| n ulp )
*
*          3: U expressed both as a dense orthogonal matrix and
*             as a product of Housholder transformations:
*             RESULT(1) = | I - VU' | / ( n ulp )
*
*  UPLO    (input) CHARACTER
*          If UPLO='U', the upper triangle of A and V will be used and
*          the (strictly) lower triangle will not be referenced.
*          If UPLO='L', the lower triangle of A and V will be used and
*          the (strictly) upper triangle will not be referenced.
*
*  N       (input) INTEGER
*          The size of the matrix.  If it is zero, DSYT21 does nothing.
*          It must be at least zero.
*
*  KBAND   (input) INTEGER
*          The bandwidth of the matrix.  It may only be zero or one.
*          If zero, then S is diagonal, and E is not referenced.  If
*          one, then S is symmetric tri-diagonal.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA, N)
*          The original (unfactored) matrix.  It is assumed to be
*          symmetric, and only the upper (UPLO='U') or only the lower
*          (UPLO='L') will be referenced.
*
*  LDA     (input) INTEGER
*          The leading dimension of A.  It must be at least 1
*          and at least N.
*
*  D       (input) DOUBLE PRECISION array, dimension (N)
*          The diagonal of the (symmetric tri-) diagonal matrix.
*
*  E       (input) DOUBLE PRECISION array, dimension (N-1)
*          The off-diagonal of the (symmetric tri-) diagonal matrix.
*          E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
*          (3,2) element, etc.
*          Not referenced if KBAND=0.
*
*  U       (input) DOUBLE PRECISION array, dimension (LDU, N)
*          If ITYPE=1 or 3, this contains the orthogonal matrix in
*          the decomposition, expressed as a dense matrix.  If ITYPE=2,
*          then it is not referenced.
*
*  LDU     (input) INTEGER
*          The leading dimension of U.  LDU must be at least N and
*          at least 1.
*
*  V       (input) DOUBLE PRECISION array, dimension (LDV, N)
*          If ITYPE=2 or 3, the columns of this array contain the
*          Householder vectors used to describe the orthogonal matrix
*          in the decomposition.  If UPLO='L', then the vectors are in
*          the lower triangle, if UPLO='U', then in the upper
*          triangle.
*          *NOTE* If ITYPE=2 or 3, V is modified and restored.  The
*          subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
*          is set to one, and later reset to its original value, during
*          the course of the calculation.
*          If ITYPE=1, then it is neither referenced nor modified.
*
*  LDV     (input) INTEGER
*          The leading dimension of V.  LDV must be at least N and
*          at least 1.
*
*  TAU     (input) DOUBLE PRECISION array, dimension (N)
*          If ITYPE >= 2, then TAU(j) is the scalar factor of
*          v(j) v(j)' in the Householder transformation H(j) of
*          the product  U = H(1)...H(n-2)
*          If ITYPE < 2, then TAU is not referenced.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N**2)
*
*  RESULT  (output) DOUBLE PRECISION array, dimension (2)
*          The values computed by the two tests described above.  The
*          values are currently limited to 1/ulp, to avoid overflow.
*          RESULT(1) is always modified.  RESULT(2) is modified only
*          if ITYPE=1.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER
      CHARACTER          CUPLO
      INTEGER            IINFO, J, JCOL, JR, JROW
      DOUBLE PRECISION   ANORM, ULP, UNFL, VSAVE, WNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSY
      EXTERNAL           LSAME, DLAMCH, DLANGE, DLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLARFY, DLASET, DORM2L, DORM2R,
     $                   DSYR, DSYR2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      WNORM = ZERO
      RESULT( 1 ) = ZERO
      IF( ITYPE.EQ.1 )
     $   RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         LOWER = .FALSE.
         CUPLO = 'U'
      ELSE
         LOWER = .TRUE.
         CUPLO = 'L'
      END IF
*
      UNFL = DLAMCH( 'Safe minimum' )
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
*     Some Error Checks
*
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         RESULT( 1 ) = TEN / ULP
         RETURN
      END IF
*
*     Do Test 1
*
*     Norm of A:
*
      IF( ITYPE.EQ.3 ) THEN
         ANORM = ONE
      ELSE
         ANORM = MAX( DLANSY( '1', CUPLO, N, A, LDA, WORK ), UNFL )
      END IF
*
*     Compute error matrix:
*
      IF( ITYPE.EQ.1 ) THEN
*
*        ITYPE=1: error = A - U S U'
*
         CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
         CALL DLACPY( CUPLO, N, N, A, LDA, WORK, N )
*
         DO 10 J = 1, N
            CALL DSYR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK, N )
   10    CONTINUE
*
         IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
            DO 20 J = 1, N - 1
               CALL DSYR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
     $                     1, WORK, N )
   20       CONTINUE
         END IF
         WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
      ELSE IF( ITYPE.EQ.2 ) THEN
*
*        ITYPE=2: error = V S V' - A
*
         CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
*
         IF( LOWER ) THEN
            WORK( N**2 ) = D( N )
            DO 40 J = N - 1, 1, -1
               IF( KBAND.EQ.1 ) THEN
                  WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J )
                  DO 30 JR = J + 2, N
                     WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J )
   30             CONTINUE
               END IF
*
               VSAVE = V( J+1, J )
               V( J+1, J ) = ONE
               CALL DLARFY( 'L', N-J, V( J+1, J ), 1, TAU( J ),
     $                      WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) )
               V( J+1, J ) = VSAVE
               WORK( ( N+1 )*( J-1 )+1 ) = D( J )
   40       CONTINUE
         ELSE
            WORK( 1 ) = D( 1 )
            DO 60 J = 1, N - 1
               IF( KBAND.EQ.1 ) THEN
                  WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J )
                  DO 50 JR = 1, J - 1
                     WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 )
   50             CONTINUE
               END IF
*
               VSAVE = V( J, J+1 )
               V( J, J+1 ) = ONE
               CALL DLARFY( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N,
     $                      WORK( N**2+1 ) )
               V( J, J+1 ) = VSAVE
               WORK( ( N+1 )*J+1 ) = D( J+1 )
   60       CONTINUE
         END IF
*
         DO 90 JCOL = 1, N
            IF( LOWER ) THEN
               DO 70 JROW = JCOL, N
                  WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
     $                - A( JROW, JCOL )
   70          CONTINUE
            ELSE
               DO 80 JROW = 1, JCOL
                  WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
     $                - A( JROW, JCOL )
   80          CONTINUE
            END IF
   90    CONTINUE
         WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
*
      ELSE IF( ITYPE.EQ.3 ) THEN
*
*        ITYPE=3: error = U V' - I
*
         IF( N.LT.2 )
     $      RETURN
         CALL DLACPY( ' ', N, N, U, LDU, WORK, N )
         IF( LOWER ) THEN
            CALL DORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU,
     $                   WORK( N+1 ), N, WORK( N**2+1 ), IINFO )
         ELSE
            CALL DORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU,
     $                   WORK, N, WORK( N**2+1 ), IINFO )
         END IF
         IF( IINFO.NE.0 ) THEN
            RESULT( 1 ) = TEN / ULP
            RETURN
         END IF
*
         DO 100 J = 1, N
            WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
  100    CONTINUE
*
         WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
      END IF
*
      IF( ANORM.GT.WNORM ) THEN
         RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
         ELSE
            RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
         END IF
      END IF
*
*     Do Test 2
*
*     Compute  UU' - I
*
      IF( ITYPE.EQ.1 ) THEN
         CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
     $               N )
*
         DO 110 J = 1, N
            WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
  110    CONTINUE
*
         RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N,
     $                 WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP )
      END IF
*
      RETURN
*
*     End of DSYT21
*
      END


Let Bool = forall A. A -> A -> A in
let true: Bool = Lambda A. lambda x: A. lambda y: A. x in
let false: Bool = Lambda A. lambda x: A. lambda y: A. y in
let not: Bool -> Bool = lambda b: Bool. Lambda A. lambda x: A. lambda y: A. b [A] y x in
let if: forall A. Bool -> A -> A -> A = Lambda A. lambda b: Bool. lambda t: A. lambda f: A. b [A] t f in
if [Bool] true false true


!----------------------------------------------------------------------
!@brief Generate coefficients for modes using current geometry,
!! mesh resolution and number of required wave-modes
!!
subroutine gen_flow_3d(dls,nels,dsigma,dlength,dtau)
  USE prec_mod
  USE constants, ONLY: f_zero, f_pi
  USE tmp_mod
  implicit none
  integer, dimension(1:3), intent(IN) :: nels   !< number of modes
  real(prec), dimension(3), intent(IN) :: dls !< Physical boundaries
  real(prec), intent(IN) :: dsigma    !< define Deviation of velocities
  real(prec), intent(IN) :: dlength   !< define Integral Length Scale
  real(prec), intent(IN) :: dtau      !< define Integral Time Scale
  integer :: ix !< number of elements by X-corrdinate
  integer :: iy !< number of elements by Y-corrdinate
  integer :: iz !< number of elements by Z-corrdinate
  real(prec) :: dx      !< cell width by X-corrdinate
  real(prec) :: dy      !< cell width by Y-corrdinate
  real(prec) :: dz      !< cell width by Z-corrdinate
  real(prec),allocatable :: dkm(:)      !< wave Length of m-th mode
  real(prec) :: kmin    !< minimal wave Length
  real(prec) :: kmax    !< maximal wave Length
  real(prec) :: kwid    !< interval between wave modes
  real(prec),allocatable :: dqm(:)      !< amplitude of

  ! real(prec) :: set_eturb     !< external function
  ! real(prec) ::set_unit_vector !< external function
  ! real(prec) ::cross_product !< external function
  ! external :: set_eturb
  ! external :: set_unit_vector
  ! external :: cross_product

  real(prec),dimension(1:3) :: tmp3     !< temporary vector 3 - elements
  real(prec),allocatable :: vtmp(:)     !< temporary vector
  ! real(prec),allocatable :: vtmp2(:,:)     !< temporary vector
  real(prec),allocatable :: dkun_i(:,:)     !< Unit vectors of wave number
  real(prec),allocatable :: dk_i(:,:)     !< wave number vector -direc
  real(prec),allocatable :: dsim_i(:,:)     !< unit direction vector in COS
  real(prec),allocatable :: dksi_i(:,:)     !< unit direction vector in SIN
  real(prec),allocatable :: dpsi(:)     !< random value in [0,2Pi)

  real(prec) :: dw_freq !< wave-time frequency multiplier
  real(prec) :: dtmp

  integer :: i  !< temporary index
  integer :: j  !< temporary index
  integer :: ist  !< Starting index
  integer :: ien  !< Ending index
  real(prec) :: rand_normal
  ! real(prec) :: dtmp1
  INTERFACE
    function set_eturb(dk, dl_in, dsigma_in) result(de)
      USE prec_mod
      implicit none
      real(prec), intent(IN) :: dk !< wave number
      real(prec), intent(IN), optional :: dl_in !< Integral Length Scale (set by default 0.1 m)
      real(prec), intent(IN), optional :: dsigma_in !< RMS of velocities (set by default 10 m/s)
      real(prec) :: de !< return value
   end function set_eturb
  end INTERFACE
  !generate random seed
  ! CALL CPU_TIME(time)
  ! CALL RANDOM_SEED(PUT=time)
  CALL random_seed_user()

  ! allocatable wave number array
  if(.NOT.ALLOCATED(dkm)) ALLOCATE(dkm(1:nmodes))
  dkm(:) = 0.0d0

  ! allocatable amplitude array
  if(.NOT.ALLOCATED(dqm)) ALLOCATE(dqm(1:nmodes))
  dqm(:) = 0.0d0

  ! Allocate unit vectors of wave number
  if(.NOT.ALLOCATED(dkun_i)) ALLOCATE(dkun_i(1:3,1:nmodes))
  dkun_i(:,:) = 0.0d0

  ! allocatable wave number vector
  if(.NOT.ALLOCATED(dk_i)) ALLOCATE(dk_i(1:3,1:nmodes))
  dk_i(:,:) = 0.0d0

  ! allocatable wave number vector in COS
  if(.NOT.ALLOCATED(dsim_i)) ALLOCATE(dsim_i(1:3,1:nmodes))
  dsim_i(:,:) = 0.0d0

  ! allocatable wave number vector in SIN
  if(.NOT.ALLOCATED(dksi_i)) ALLOCATE(dksi_i(1:3,1:nmodes))
  dksi_i(:,:) = 0.0d0

  ! allocatable random value
  if(.NOT.ALLOCATED(dpsi)) ALLOCATE(dpsi(1:nmodes))
  dpsi(:) = 0.0d0

  ix = nels(1)
  iy = nels(2)
  iz = nels(3)

  ! set cell width
  dx = dls(1) / REAL(nels(1),prec)
  dy = dls(2) / REAL(nels(2),prec)
  dz = dls(3) / REAL(nels(3),prec)

  ! 2-3 -  define minimal wave Length
  kmin = 0.0d0
  kmax = 0.0d0
  do i=1, 3
    kmin = MAX(kmin,2.0d0 * f_pi / dls(i))
    kmax = MAX(kmax,2.0d0*f_pi * DBLE(nels(i)) / dls(i))
  enddo

  ! 4 - Generate a list of M equidistant modes:
  !   $$k_m = k_o + \frac{k_{max}-k_o}{M} (m - 1) $$
  kwid = (kmax - kmin) / DBLE(nmodes)
  ! set waves for modes
  do i = 1, nmodes
    dkm(i) = kmin + kwid * DBLE(i - 1)
    !5 - generate amplitudes by equation $q_m = \sqrt{E(k_m)\Delta k}$
    !       Get SQRT below
    dqm(i) = set_eturb(dkm(i),dl_in=dlength,dsigma_in=dsigma) * kwid
  enddo

  ! 6 - 7 Calculate wave number vector
  ! ALLOCATE(vtmp(1:3,1:nmodes))
  if(.NOT.ALLOCATED(vtmp)) ALLOCATE(vtmp(1:nmodes*4))

  CALL RANDOM_NUMBER(vtmp(:))

  do i = 1, nmodes
    ! generate unit vector in 3D space
    ! tmp3(1:3) = set_unit_vector(vtmp(1+3*(i-1):3*i))
    j = 3 * i - 2
    ! CALL set_unit_vector_sub(vtmp(j:j+1),tmp3(1:3))
    CALL set_unit_vector_sub(vtmp(j:j+2),tmp3(1:3))
    dkun_i(1:3,i) = tmp3(1:3) !set_unit_vector(vtmp(1:2,i))
    dk_i(1:3,i) = tmp3(1:3) !set_unit_vector(vtmp(1:2,i))
    ! dk_i(1,i) = 2.0d0 * SIN(5.0d-1 * dx * dkm(i) * tmp3(1)) / dx
    ! dk_i(2,i) = 2.0d0 * SIN(5.0d-1 * dy * dkm(i) * tmp3(2)) / dy
    ! dk_i(3,i) = 2.0d0 * SIN(5.0d-1 * dz * dkm(i) * tmp3(3)) / dz
    !----------
    ! Set another distribution
    dk_i(1,i) = 1.0d0 * SIN(1.0d-0 * dx * dkm(i) * tmp3(1)) / dx
    dk_i(2,i) = 1.0d0 * SIN(1.0d-0 * dy * dkm(i) * tmp3(2)) / dy
    dk_i(3,i) = 1.0d0 * SIN(1.0d-0 * dz * dkm(i) * tmp3(3)) / dz
  enddo

  ! 8 - Define random unity vectors
  CALL RANDOM_NUMBER(vtmp(1:nmodes*4))

 ! 9 - generate (unit) direction vector
  do i= 1, nmodes
    CALL set_unit_vector_sub(vtmp(4*i-3),tmp3(1:3))
    !-----------------------------
    ! Set addtitional conditions for Periodic BND
    !-----------------------------
    ! tmp3(1) = SIN(5.0d-1 * (dls(1) - dx) * dkm(i) * dkun_i(1,i))
    ! tmp3(2) = SIN(5.0d-1 * (dls(2) - dy) * dkm(i) * dkun_i(2,i))
    ! tmp3(3) = SIN(5.0d-1 * (dls(3) - dz) * dkm(i) * dkun_i(3,i))
    ! tmp3(2) = SIGN(1.0d0,vtmp(4*i-2)-5.0d-1) * SQRT(ABS(1.0d0-tmp3(1)**2-tmp3(3)**2))
    !!!!!!!
    !
    CALL cross_product_sub(tmp3(1:3), dk_i(1:3,i),dsim_i(1:3,i))

    ! 9b - set for second unit vector in SIN coefficients
    CALL set_unit_vector_sub(vtmp(4*i-1),tmp3(1:3))
    CALL cross_product_sub(tmp3(1:3), dk_i(1:3,i),dksi_i(1:3,i))
    ! CALL cross_product_sub(dsim_i(1:3,i), dk_i(1:3,i),dksi_i(1:3,i))
  enddo

  ! 10 - Generate random value
  ! CALL RANDOM_NUMBER(dpsi(1:nmodes))
  ! dw_freq = 1.0d0
  ! dpsi(:) = dpsi(:) * 2.0d0 * f_pi * dkm(:) * dsigma
  !! According to @cite{juve_1999.pdf} use Gauss distribution function
  do i=1, nmodes
    dtmp = dkm(i) * dsigma
    dpsi(i) = rand_normal(dtmp,dtmp)
  enddo

  ! 11 - Calculate velocities in every point

  ! write(*,*) "Generate Spectrum profile"
  ! OPEN(UNIT=123,FILE='tests/spectr.dat')
  ! do i= 1, nmodes
  !   ! dtmp = 10. + 10.*(i-1)
  !   ! dtmp1 = set_eturb(dtmp,dlength,dsigma)
  !   ! write(*,'(2es13.5)')dtmp, dtmp1
  !   ! if (dtmp /= dtmp) write(*,*) "Some errors"
  !   ! write(*,'(3es13.5)') dkm(i),set_eturb(dkm(i),dlength,dsigma), dqm(i)
  !   write(123,'(3es13.5)') dkm(i),set_eturb(dkm(i),dl_in=dlength,dsigma_in=dsigma), dqm(i)
  ! enddo
  ! CLOSE(123)

  !fill the coefficients in from tmp_mod
  ist = in_time
  ien = in_time + nmodes - 1

  do i = 1, 3
    CALL rand_normal_sub(nmodes,0.0d0,1.0d0,vtmp(1:nmodes))
    ! ac_m(i,ist:ien) = dsim_i(i,:) * SQRT(dqm(:))
    ac_m(i,ist:ien) = dsim_i(i,:) * SQRT(dqm(:) * vtmp(1:nmodes)**2 * 1.0d0  &
      /(1.0d0+vtmp(1:nmodes)**2))* SIGN(1.0d0,vtmp(1:nmodes))
      ! /(1.0d0+vtmp(1:nmodes)**2)/DBLE(ntimes))* SIGN(1.0d0,vtmp(1:nmodes))
    as_m(i,ist:ien) = dksi_i(i,:) * SQRT(dqm(:) *1.0d0                       &
      /(1.0d0+vtmp(1:nmodes)**2))* SIGN(1.0d0,vtmp(1:nmodes))
      ! /(1.0d0+vtmp(1:nmodes)**2)/DBLE(ntimes))* SIGN(1.0d0,vtmp(1:nmodes))
    b_m(i,ist:ien)  = dkun_i(i,:) * dkm(:)
  enddo

  ! WRITE(*,*) "Switch Time coefficiet in `gen_flow_3d` !!!"

  ! do i= 1, nmodes
  !   j = i + ist - 1
  !   c_m(j)  = dpsi(i) * dsigma * dkm(i)
  ! enddo
  c_m(ist:ien) = dpsi(1:nmodes) !* dkm(:) * dsigma /3.0d0/4.0d0
  ! c_m(:)  = dpsi(:)

  write(*,*) "END: Generate Spectrum profile"

  ! CALL RANDOM_NUMBER(vels(1:3,1:ix,1:iy,1:iz))

  RETURN
end subroutine gen_flow_3d
!----------------------------------------------------------------------


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!===============================================================================================
! Unit tests for methods of weights (equality-constrained LSQR).
!
! Author: Vitaliy Ogarko, UWA, CET, Australia, 2016.
!===============================================================================================
module tests_method_of_weights

  use global_typedefs
  use ftnunit

  use sparse_matrix
  use lsqr_solver
  use method_of_weights

  implicit none

  private

  ! Testing a well-conditioned system, whose matrix rows vary in norm.
  public :: test_method_of_weights_1

  ! Testing a well-conditioned system.
  public :: test_method_of_weights_2

contains

!=============================================================================================
! Use an example (small system) from Ref. [1], page 856 (top).
! [1] Charles Van Loan, On the Method of Weighting for Equality-Constrained Least-Squares Problems,
!     SIAM J. Numer. Anal., Vo. 22, No. 5, 1985.
!
! A = ( 1 2 ), b = ( 1 ), B = (1, - 1), d = (2).
!     ( 3 4 )      ( 1 )
!
!=============================================================================================
subroutine test_method_of_weights_1(myrank, nbproc)
  integer, intent(in) :: myrank, nbproc

  real(kind=CUSTOM_REAL), allocatable :: b(:)
  real(kind=CUSTOM_REAL), allocatable :: y(:)
  real(kind=CUSTOM_REAL), allocatable :: y_LSE(:)
  real(kind=CUSTOM_REAL), allocatable :: g(:)
  type(t_sparse_matrix) :: matrix_A, matrix_C
  type(t_parameters_lsqr) :: par
  integer :: ncols, ncols_loc
  integer :: ierr
  integer :: nrows_A, nrows_C, niter
  real(kind=CUSTOM_REAL) :: tau

  if (nbproc > 1) then
    if (myrank == 0) print *, "WARNING: test_method_of_weights_1 is not yet adjusted for parallel runs, skipping the test."
    return
  endif

  tau = 1.d3
  niter = 3

  ncols = 2
  nrows_A = 3
  nrows_C = 1

  ncols_loc = ncols / nbproc

  par%rmin = 1.e-13_CUSTOM_REAL
  par%niter = 20
  par%gamma = 0._CUSTOM_REAL

  if (mod(ncols, nbproc) /= 0) then
    if (myrank == 0) print *, "WARNING: ncols mod nbproc /= 0, skipping the test."
    return
  endif

  call matrix_A%initialize(nrows_A, ncols_loc * nrows_A, myrank)
  call matrix_C%initialize(nrows_C, ncols_loc * nrows_C, myrank)

  allocate(b(nrows_A), source=0._CUSTOM_REAL, stat=ierr)
  allocate(y(ncols_loc), source=0._CUSTOM_REAL, stat=ierr)
  allocate(y_LSE(ncols_loc), source=0._CUSTOM_REAL, stat=ierr)
  allocate(g(nrows_C), source=0._CUSTOM_REAL, stat=ierr)

  ! Build matrix C. ---------------
  call matrix_C%new_row(myrank)

  call matrix_C%add(1.d0, 1, myrank)
  call matrix_C%add(- 1.d0, 2, myrank)

  call matrix_C%finalize(ncols_loc, myrank)

  ! Build matrix A. --------------
  call matrix_A%new_row(myrank)

  call matrix_A%add(1.d0, 1, myrank)
  call matrix_A%add(2.d0, 2, myrank)

  call matrix_A%new_row(myrank)

  call matrix_A%add(3.d0, 1, myrank)
  call matrix_A%add(4.d0, 2, myrank)

  call matrix_A%add_matrix(matrix_C, tau, myrank)

  call matrix_A%finalize(ncols_loc, myrank)

  ! Build right-hand sides. ---------
  b(1) = 1.d0
  b(2) = 1.d0

  g(1) = 2.d0

  b(3:3) = tau * g

  !----------------------------------------------------------
  ! Solve: find y = y(tau).
  call lsqr_solve(par%niter, par%rmin, par%gamma, matrix_A, b, y, myrank)

  ! Apply method of weights to correct y.
  call apply_method_of_weights(par, niter, matrix_A, matrix_C, y, b, g, tau, 3, myrank)

  !----------------------------------------------------------
  ! Compare results with analytical solution y_LSE.

  y_LSE(1) =  (1.d0 / 29.d0) * 39.d0
  y_LSE(2) =  (1.d0 / 29.d0) * (- 19.d0)

!  call assert_true(abs(y(1) - y_LSE(1)) / abs(y_LSE(1)) < 1.e-15_CUSTOM_REAL, "y(1) is not correct in test_method_of_weights_1.")
!  call assert_true(abs(y(2) - y_LSE(2)) / abs(y_LSE(2)) < 1.e-15_CUSTOM_REAL, "y(2) is not correct in test_method_of_weights_1.")

  ! Somehow the exact solution is found (with gcc 4.9.4). Not sure if this is true for other machines/compilers...
  ! If this fails, use the above version.
  call assert_true(abs(y(1) - y_LSE(1)) / abs(y_LSE(1)) == 0._CUSTOM_REAL, "y(1) is not correct in test_method_of_weights_1.")
  call assert_true(abs(y(2) - y_LSE(2)) / abs(y_LSE(2)) == 0._CUSTOM_REAL, "y(2) is not correct in test_method_of_weights_1.")

  deallocate(b)
  deallocate(y)
  deallocate(y_LSE)
  deallocate(g)

end subroutine test_method_of_weights_1

!=============================================================================================
! Use an example of a well-conditioned system in Ref. [1], by Per-Ake Wedin, page 856.
! [1] Charles Van Loan, SIAM J. Numer. Anal., Vo. 22, No. 5, 1985.
!=============================================================================================
subroutine test_method_of_weights_2(myrank, nbproc)
  integer, intent(in) :: myrank, nbproc

  real(kind=CUSTOM_REAL), allocatable :: b(:)
  real(kind=CUSTOM_REAL), allocatable :: y(:)
  real(kind=CUSTOM_REAL), allocatable :: y_LSE(:)
  real(kind=CUSTOM_REAL), allocatable :: g(:)
  type(t_sparse_matrix) :: matrix_A, matrix_C
  type(t_parameters_lsqr) :: par
  integer :: ncols, ncols_loc
  integer :: ierr
  integer :: nrows_A, nrows_C, niter
  real(kind=CUSTOM_REAL) :: tau

  if (nbproc > 1) then
    if (myrank == 0) print *, "WARNING: test_method_of_weights_2 is not yet adjusted for parallel runs, skipping the test."
    return
  endif

  tau = 1.d3
  niter = 3

  ncols = 3
  nrows_A = 6
  nrows_C = 2

  ncols_loc = ncols / nbproc

  par%rmin = 1.e-13_CUSTOM_REAL
  par%niter = 20
  par%gamma = 0._CUSTOM_REAL

  if (mod(ncols, nbproc) /= 0) then
    if (myrank == 0) print *, "WARNING: ncols mod nbproc /= 0, skipping the test."
    return
  endif

  call matrix_A%initialize(nrows_A, ncols_loc * nrows_A, myrank)
  call matrix_C%initialize(nrows_C, ncols_loc * nrows_C, myrank)

  allocate(b(nrows_A), source=0._CUSTOM_REAL, stat=ierr)
  allocate(y(ncols_loc), source=0._CUSTOM_REAL, stat=ierr)
  allocate(y_LSE(ncols_loc), source=0._CUSTOM_REAL, stat=ierr)
  allocate(g(nrows_C), source=0._CUSTOM_REAL, stat=ierr)

  ! Build matrix C. ---------------
  call matrix_C%new_row(myrank)

  call matrix_C%add(1.d0, 1, myrank)
  call matrix_C%add(1.d0, 2, myrank)
  call matrix_C%add(1.d0, 3, myrank)

  call matrix_C%new_row(myrank)

  call matrix_C%add(1.d0, 1, myrank)
  call matrix_C%add(1.d0, 2, myrank)
  call matrix_C%add(- 1.d0, 3, myrank)

  call matrix_C%finalize(ncols_loc, myrank)

  ! Build matrix A. --------------
  call matrix_A%new_row(myrank)

  call matrix_A%add(1.d0, 1, myrank)
  call matrix_A%add(1.d0, 2, myrank)
  call matrix_A%add(1.d0, 3, myrank)

  call matrix_A%new_row(myrank)

  call matrix_A%add(1.d0, 1, myrank)
  call matrix_A%add(3.d0, 2, myrank)
  call matrix_A%add(1.d0, 3, myrank)

  call matrix_A%new_row(myrank)

  call matrix_A%add(1.d0, 1, myrank)
  call matrix_A%add(- 1.d0, 2, myrank)
  call matrix_A%add(1.d0, 3, myrank)

  call matrix_A%new_row(myrank)

  call matrix_A%add(1.d0, 1, myrank)
  call matrix_A%add(1.d0, 2, myrank)
  call matrix_A%add(1.d0, 3, myrank)

  call matrix_A%add_matrix(matrix_C, tau, myrank)

  call matrix_A%finalize(ncols_loc, myrank)

  ! Build right-hand sides. ---------
  b(1) = 1.d0
  b(2) = 2.d0
  b(3) = 3.d0
  b(4) = 4.d0

  g(1) = 7.d0
  g(2) = 4.d0

  b(5:6) = tau * g

  !----------------------------------------------------------
  ! Solve: find y = y(tau).
  call lsqr_solve(par%niter, par%rmin, par%gamma, matrix_A, b, y, myrank)

  ! Apply method of weights to correct y.
  call apply_method_of_weights(par, niter, matrix_A, matrix_C, y, b, g, tau, 3, myrank)

  !----------------------------------------------------------
  ! Compare results with analytical solution y_LSE.

  y_LSE(1) =  (1.d0 / 8.d0) * 46.d0
  y_LSE(2) =  (1.d0 / 8.d0) * (- 2.d0)
  y_LSE(3) =  (1.d0 / 8.d0) * 12.d0

  call assert_true(abs(y(1) - y_LSE(1)) / abs(y_LSE(1)) < 1.e-15_CUSTOM_REAL, "y(1) is not correct in test_method_of_weights_2.")
  call assert_true(abs(y(2) - y_LSE(2)) / abs(y_LSE(2)) < 1.e-15_CUSTOM_REAL, "y(2) is not correct in test_method_of_weights_2.")
  call assert_true(abs(y(3) - y_LSE(3)) / abs(y_LSE(3)) < 1.e-15_CUSTOM_REAL, "y(3) is not correct in test_method_of_weights_2.")

  deallocate(b)
  deallocate(y)
  deallocate(y_LSE)
  deallocate(g)

end subroutine test_method_of_weights_2

end module tests_method_of_weights


module futils_sorting
! Module for sorting arrays.
! From github.com/certik/fortran-utils
! MIT license (included).
!
! Adapted to be self-contained, LKedward Feb. 2020
!
! Based on code written by John E. Pask, LLNL.

  use iso_fortran_env, only: dp => real64
  implicit none
  private
  public sort, sortpairs, argsort

! overload argsort
  interface argsort
    module procedure iargsort, rargsort
  endinterface

! overload sort
  interface sort
    module procedure sortNums, sortINums, sortVecs
  endinterface

! overload sortpairs
  interface sortpairs
    module procedure sortNumNumPairs, sortINumCNumPairs, &
      sortNumVecPairs, sortINumVecPairs, sortNumCVecPairs, &
      sortNumMatPairs, sortINumMatPairs
  endinterface

contains

  subroutine sortNums(nums)
! sorts array of numbers, nums, from smallest to largest
    real(dp), intent(inout):: nums(:)   ! array of numbers
    nums = nums(argsort(nums))
  endsubroutine

  subroutine sortINums(nums)
! sorts array of inegers, nums, from smallest to largest
    integer, intent(inout):: nums(:)    ! array of numbers
    nums = nums(argsort(nums))
  endsubroutine

  subroutine sortVecs(vecs)
! sorts array of vectors, vecs, by length, from smallest to largest
    real(dp), intent(inout):: vecs(:, :) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
    real(dp) len2(size(vecs, 2))         ! array of squares of vector lengths
    integer i
    do i = 1, size(len2)
      len2(i) = dot_product(vecs(:, i), vecs(:, i))
    enddo
    call sortpairs(len2, vecs)
  endsubroutine

  subroutine sortNumNumPairs(nums1, nums2)
! sorts arrays of numbers, nums1 and nums2, according to increasing nums1
    real(dp), intent(inout):: nums1(:), nums2(:)  ! arrays of numbers
    integer :: a(size(nums1))
    if(size(nums1) /= size(nums2)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums1)
    nums1 = nums1(a)
    nums2 = nums2(a)
  endsubroutine

  subroutine sortINumCNumPairs(nums1, nums2)
! sorts arrays of numbers, nums1 and nums2, according to increasing nums1
    integer, intent(inout):: nums1(:)            ! array of integers
    complex(dp), intent(inout):: nums2(:)        ! array of complex numbers
    integer :: a(size(nums1))
    if(size(nums1) /= size(nums2)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums1)
    nums1 = nums1(a)
    nums2 = nums2(a)
  endsubroutine

  subroutine sortNumVecPairs(nums, vecs)
! sorts arrays of numbers, nums, and vectors, vecs, according to increasing nums
    real(dp), intent(inout):: nums(:)   ! array of numbers
    real(dp), intent(inout):: vecs(:, :) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
    integer :: a(size(nums))
    if(size(nums) /= size(vecs, 2)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums)
    nums = nums(a)
    vecs = vecs(:, a)
  endsubroutine

  subroutine sortINumVecPairs(nums, vecs)
! sorts arrays of integers, nums, and vectors, vecs, according to increasing nums
    integer, intent(inout):: nums(:)    ! array of numbers
    real(dp), intent(inout):: vecs(:, :) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
    integer :: a(size(nums))
    if(size(nums) /= size(vecs, 2)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums)
    nums = nums(a)
    vecs = vecs(:, a)
  endsubroutine

  subroutine sortNumCVecPairs(nums, vecs)
! sorts arrays of numbers, nums, and complex vectors, vecs, according to increasing nums
    real(dp), intent(inout):: nums(:)   ! array of numbers
    complex(dp), intent(inout):: vecs(:, :) ! array of vectors: vecs(i,j) = ith comp. of jth vec.
    integer :: a(size(nums))
    if(size(nums) /= size(vecs, 2)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums)
    nums = nums(a)
    vecs = vecs(:, a)
  endsubroutine

  subroutine sortNumMatPairs(nums, mats)
! sorts arrays of numbers, nums, and matrices, mats, according to increasing nums
    real(dp), intent(inout):: nums(:)         ! array of numbers
    real(dp), intent(inout):: mats(:, :, :)     ! array of matrices: mats(i,j,n) = (i,j) comp. of nth mat.
    integer :: a(size(nums))
    if(size(nums) /= size(mats, 3)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums)
    nums = nums(a)
    mats = mats(:, :, a)
  endsubroutine

  subroutine sortINumMatPairs(nums, mats)
! sorts arrays of integers, nums, and matrices, mats, according to increasing nums
    integer, intent(inout):: nums(:)          ! array of numbers
    real(dp), intent(inout):: mats(:, :, :)     ! array of matrices: mats(i,j,n) = (i,j) comp. of nth mat.
    integer :: a(size(nums))
    if(size(nums) /= size(mats, 3)) then
      call stop_error("arrays must be of same length.")
    endif
    a = argsort(nums)
    nums = nums(a)
    mats = mats(:, :, a)
  endsubroutine

  function iargsort(a) result(b)
! Returns the indices that would sort an array.
!
! Arguments
! ---------
!
    integer, intent(in):: a(:)    ! array of numbers
    integer :: b(size(a))         ! indices into the array 'a' that sort it
!
! Example
! -------
!
! iargsort([10, 9, 8, 7, 6])   ! Returns [5, 4, 3, 2, 1]

    integer :: N                           ! number of numbers/vectors
    integer :: i, imin                      ! indices: i, i of smallest
    integer :: temp                        ! temporary
    integer :: a2(size(a))
    a2 = a
    N = size(a)
    do i = 1, N
      b(i) = i
    enddo
    do i = 1, N - 1
      ! find ith smallest in 'a'
      imin = minloc(a2(i:), 1) + i - 1

      ! swap to position i in 'a' and 'b', if not already there
      if(imin /= i) then
        temp = a2(i); a2(i) = a2(imin); a2(imin) = temp
        temp = b(i); b(i) = b(imin); b(imin) = temp
      endif
    enddo
  endfunction

  function rargsort(a) result(b)
! Returns the indices that would sort an array.
!
! Arguments
! ---------
!
    real(dp), intent(in):: a(:)   ! array of numbers
    integer :: b(size(a))         ! indices into the array 'a' that sort it
!
! Example
! -------
!
! rargsort([4.1_dp, 2.1_dp, 2.05_dp, -1.5_dp, 4.2_dp]) ! Returns [4, 3, 2, 1, 5]

    integer :: N                           ! number of numbers/vectors
    integer :: i, imin                      ! indices: i, i of smallest
    integer :: temp1                       ! temporary
    real(dp) :: temp2
    real(dp) :: a2(size(a))
    a2 = a
    N = size(a)
    do i = 1, N
      b(i) = i
    enddo
    do i = 1, N - 1
      ! find ith smallest in 'a'
      imin = minloc(a2(i:), 1) + i - 1
      ! swap to position i in 'a' and 'b', if not already there
      if(imin /= i) then
        temp2 = a2(i); a2(i) = a2(imin); a2(imin) = temp2
        temp1 = b(i); b(i) = b(imin); b(imin) = temp1
      endif
    enddo
  endfunction

  subroutine stop_error(msg)
! Aborts the program with nonzero exit code
!
! The statement "stop msg" will return 0 exit code when compiled using
! gfortran. stop_error() uses the statement "stop 1" which returns an exit code
! 1 and a print statement to print the message.
!
! Example
! -------
!
! call stop_error("Invalid argument")

    character(len=*) :: msg ! Message to print on stdout
    write(*, *) " (!) fortran-utils:mod_sorting Error: ", msg
    stop 1
  endsubroutine

endmodule futils_sorting


PROGRAM main

  USE mo_kind,     ONLY: dp, sp
  USE mo_interpol, ONLY: interpol, spline_b
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  REAL(dp), DIMENSION(10) :: dyin, dyout, dx, dsoll
  LOGICAL,  DIMENSION(10) :: mask
  REAL(sp), DIMENSION(10) :: syin, syout, sx, ssoll

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_interpol.f90'

  ! Double precision
  isgood = .true.
  dsoll   = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  dx      = dsoll
  dyin    = dsoll
  mask(:) = .true.
  dyin(5) = -9.
  mask(5) = .false.

  dyout = interpol(pack(dyin,mask), pack(dx,mask), dx)
  if (any(abs(dsoll-dyout) > 0._dp)) isgood = .false.

  dyout = spline_b(pack(dyin,mask), pack(dx,mask), dx)
  if ((nint(dsoll(5))-nint(dyout(5))) > 0) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_interpol double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_interpol double precision ', color('failed.', c_red)
  endif

  ! Single precision
  isgood = .true.
  ssoll   = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  sx      = ssoll
  syin    = ssoll
  mask(:) = .true.
  syin(5) = -9.
  mask(5) = .false.

  syout = interpol(pack(syin,mask), pack(sx,mask), sx)
  if (any(abs(ssoll-syout) > 0._sp)) isgood = .false.

  syout = spline_b(pack(syin,mask), pack(sx,mask), sx)
  if ((nint(ssoll(5))-nint(syout(5))) > 0) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_interpol single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_interpol single precision ', color('failed.', c_red)
  endif

END PROGRAM main


! PR fortran/70855
! { dg-do compile }
! { dg-additional-options "-O2" }

program pr70855
   integer, parameter :: m = 4
   integer, parameter :: n = 2
   real :: a(m,n)
   real :: x(n)
   real :: y(m)
   a = 1.0
   x = 1.0
!$omp parallel
!$omp workshare
   y(1:m) = matmul ( a(1:m,1:n), x(1:n) )
!$omp end workshare
!$omp end parallel
end program pr70855