C
C     ..................................................................
C
C        SUBROUTINE DGELS
C
C        PURPOSE
C           TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH
C           SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH
C           IS ASSUMED TO BE STORED COLUMNWISE.
C
C        USAGE
C           CALL DGELS(R,A,M,N,EPS,IER,AUX)
C
C        DESCRIPTION OF PARAMETERS
C           R      - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
C                    (DESTROYED). ON RETURN R CONTAINS THE SOLUTION OF
C                    THE EQUATIONS.
C           A      - UPPER TRIANGULAR PART OF THE SYMMETRIC DOUBLE
C                    PRECISION M BY M COEFFICIENT MATRIX.  (DESTROYED)
C           M      - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C           N      - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C           EPS    - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C                    RELATIVE TOLERANCE FOR TEST ON LOSS OF
C                    SIGNIFICANCE.
C           IER    - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C                    IER=0  - NO ERROR,
C                    IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C                             PIVOT ELEMENT AT ANY ELIMINATION STEP
C                             EQUAL TO 0,
C                    IER=K  - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C                             CANCE INDICATED AT ELIMINATION STEP K+1,
C                             WHERE PIVOT ELEMENT WAS LESS THAN OR
C                             EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C                             ABSOLUTELY GREATEST MAIN DIAGONAL
C                             ELEMENT OF MATRIX A.
C           AUX    - DOUBLE PRECISION AUXILIARY STORAGE ARRAY
C                    WITH DIMENSION M-1.
C
C        REMARKS
C           UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED
C           COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT
C           HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE
C           LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE
C           TOO.
C           THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C           GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C           ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C           INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C           SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C           INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C           GIVEN IN CASE M=1.
C           ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT
C           MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS
C           ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE DGELG (WHICH
C           WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION.
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C           PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE
C           SYMMETRY IN REMAINING COEFFICIENT MATRICES.
C
C     ..................................................................
C
      SUBROUTINE DGELS(R,A,M,N,EPS,IER,AUX)
C
C
      DIMENSION A(1),R(1),AUX(1)
      DOUBLE PRECISION R,A,AUX,PIV,TB,TOL,PIVI
      IF(M)24,24,1
C
C     SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT
    1 IER=0
      PIV=0.D0
      L=0
      DO 3 K=1,M
      L=L+K
      TB=DABS(A(L))
      IF(TB-PIV)3,3,2
    2 PIV=TB
      I=L
      J=K
    3 CONTINUE
      TOL=EPS*PIV
C     MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT.
C     PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C     START ELIMINATION LOOP
      LST=0
      NM=N*M
      LEND=M-1
      DO 18 K=1,M
C
C     TEST ON USEFULNESS OF SYMMETRIC ALGORITHM
      IF(PIV)24,24,4
    4 IF(IER)7,5,7
    5 IF(PIV-TOL)6,6,7
    6 IER=K-1
    7 LT=J-K
      LST=LST+K
C
C     PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
      PIVI=1.D0/A(I)
      DO 8 L=K,NM,M
      LL=L+LT
      TB=PIVI*R(LL)
      R(LL)=R(L)
    8 R(L)=TB
C
C     IS ELIMINATION TERMINATED
      IF(K-M)9,19,19
C
C     ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A.
C     ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX.
    9 LR=LST+(LT*(K+J-1))/2
      LL=LR
      L=LST
      DO 14 II=K,LEND
      L=L+II
      LL=LL+1
      IF(L-LR)12,10,11
   10 A(LL)=A(LST)
      TB=A(L)
      GO TO 13
   11 LL=L+LT
   12 TB=A(LL)
      A(LL)=A(L)
   13 AUX(II)=TB
   14 A(L)=PIVI*TB
C
C     SAVE COLUMN INTERCHANGE INFORMATION
      A(LST)=LT
C
C     ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT
      PIV=0.D0
      LLST=LST
      LT=0
      DO 18 II=K,LEND
      PIVI=-AUX(II)
      LL=LLST
      LT=LT+1
      DO 15 LLD=II,LEND
      LL=LL+LLD
      L=LL+LT
   15 A(L)=A(L)+PIVI*A(LL)
      LLST=LLST+II
      LR=LLST+LT
      TB=DABS(A(LR))
      IF(TB-PIV)17,17,16
   16 PIV=TB
      I=LR
      J=II+1
   17 DO 18 LR=K,NM,M
      LL=LR+LT
   18 R(LL)=R(LL)+PIVI*R(LR)
C     END OF ELIMINATION LOOP
C
C
C     BACK SUBSTITUTION AND BACK INTERCHANGE
   19 IF(LEND)24,23,20
   20 II=M
      DO 22 I=2,M
      LST=LST-II
      II=II-1
      L=A(LST)+.5D0
      DO 22 J=II,NM,M
      TB=R(J)
      LL=J
      K=LST
      DO 21 LT=II,LEND
      LL=LL+1
      K=K+LT
   21 TB=TB-A(K)*R(LL)
      K=J+L
      R(J)=R(K)
   22 R(K)=TB
   23 RETURN
C
C
C     ERROR RETURN
   24 IER=-1
      RETURN
      END


!!# USER MODULE: <<USR_SBCharacteristics>>
MODULE USR_SBCharacteristics

!!## PURPOSE
!! Provides user routines for the subcell balance characteristic
!! method of Karpov [ref] for solution of the linearized Boltzmann
!! transport equation.

!!## NOTES
!!

!!## VERSION 0.03

!!## CHANGES
!! * v0.03 (2011-09-01) - Problem with parabolic piecewise interpolator exploding
!!                        for thin sub-slices!  Current solution: do not allow tstar
!!                        to be closer to a side than 1.2*minimum edge thickness.
!! * v0.02 (2011-07-10) - Changed qmc_DiscontinuousFix to base its placement
!!                        of the outgoing verts on the incoming verts, so
!!                        now we need to pass InVerts as an argument.  Corrected
!!                        qmc_Ds to have the correct formula.
!! * v0.01 (2011-07-09) - Original version.

!!## EXTERNAL KINDS
USE KND_Characteristics !!((03-C-KND_Characteristics.f90))
USE FUN_Error           !!((04-A-FUN_Error.f90))
USE FUN_IsError         !!((05-A-FUN_IsError.f90))
USE USR_PolyExpoMoment  !!((11-C-USR_PolyExpoMoment.f90))
USE FUN_Default         !!((04-A-FUN_Default.f90))
USE FUN_STR             !!((05-B-FUN_STR.f90))
USE LIB_SubcellBalances !!((12-C-LIB_SubcellBalances.f90))
USE FUN_xyPERPCCW       !!((03-A-FUN_xyPERPCCW.f90))
USE FUN_xyPERPCW        !!((04-A-FUN_xyPERPCW.f90))
USE FUN_xyDIRECTION     !!((04-B-FUN_xyDIRECTION.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PUBLIC ACCESS LISTING
!! * basic real kind
PUBLIC :: KIND_qmc
!! * initializer and printer
PUBLIC :: qmc_INIT
PUBLIC :: qmc_PRINT
!! * geometry bounds
PUBLIC :: qmc_t1                    !qmc_t1()
PUBLIC :: qmc_t2                    !qmc_t2()
PUBLIC :: qmc_Dt                    !qmc_Dt()
PUBLIC :: qmc_smin                  !qmc_smin(t)
PUBLIC :: qmc_smax                  !qmc_smax(t)
PUBLIC :: qmc_Ds                    !qmc_Ds(t)
PUBLIC :: qmc_AreaSli               !qmc_AreaSli
PUBLIC :: qmc_LenSliIn              !qmc_LenSliIn
PUBLIC :: qmc_LenSliOut             !qmc_LenSliOut
!! * functions of (s,t) within the slice (normal and simple interface)
PUBLIC :: qmc_PsiSB                 !qmc_PsiSB(s,t)
PUBLIC :: qmc_PsiSB0                !qmc_PsiSB0(s,t)
PUBLIC :: qmc_Q                     !qmc_Q(s,t)
!! * functions of (t) within the slice (incoming and outgoing)
PUBLIC :: qmc_PsiSB_in              !qmc_PsiSB_in(t)
PUBLIC :: qmc_PsiSB_out             !qmc_PsiSB_out(t)
!! * functions with no arguments
PUBLIC :: qmc_PsiSB_int      !integrated within slice
PUBLIC :: qmc_PsiSB_intin    !integrated incoming
PUBLIC :: qmc_PsiSB_intout   !integrated outgoing
PUBLIC :: qmc_PsiSB_out1     !outgoing left point
PUBLIC :: qmc_PsiSB_out2     !outgoing right point
!! * utility functions
PUBLIC :: qmc_PsiEdge_from_2Pt1Avg  !one parabola
PUBLIC :: qmc_PsiEdge2_from_2Pt1Avg !piecewise parabola
PUBLIC :: qmc_PsiInOut_from_PsiEdge

PUBLIC :: qmc_Q_from_QXY
PUBLIC :: qmc_CalcBalance

PUBLIC :: qmc_ThinEdgeCount
PUBLIC :: qmc_ThinEdgeCheck
PUBLIC :: qmc_DiscontinuousFix

PUBLIC :: PParaInterpolant_Karpov
PUBLIC :: CWENO_Parabola_2Pt1Avg

PUBLIC :: TEST_Karpov

PUBLIC :: PRINT_PPara
PUBLIC :: GNUPLOT_PPara

!!## LOCAL PARAMETERS
!! * keys for interpolation
CHARACTER(*),PARAMETER :: KEYS_EdgeInterpolator(6)=(/"Parabolic      ",&
                                                     "LinearEdges    ",&
                                                     "LinearAverage  ",&
                                                     "Flat           ",&
                                                     "CWENO          ",&
                                                     "ParabolicKarpov"/)
!! * indices corresponding to above edgeinterpolator keys
INTEGER,PARAMETER :: QMC_PARABOLIC=1
INTEGER,PARAMETER :: QMC_LINEAREDGES=2
INTEGER,PARAMETER :: QMC_LINEARAVERAGE=3
INTEGER,PARAMETER :: QMC_FLAT=4
INTEGER,PARAMETER :: QMC_CWENO=5
INTEGER,PARAMETER :: QMC_PARABOLICKARPOV=6

!!## LOCAL VARIABLES
!! * variables
REAL(KIND_qmc) :: a,b,c
REAL(KIND_qmc) :: q1,qs,qt
REAL(KIND_qmc) :: t1,smin1,smax1
REAL(KIND_qmc) :: t2,smin2,smax2
REAL(KIND_qmc) :: LenSliIn,LenSliOut
REAL(KIND_qmc) :: AreaSli
INTEGER,SAVE   :: slice_id
REAL(KIND_qmc) :: sigma,sintheta
INTEGER        :: COUNT_ThinEdges = 0

!! * options
REAL(KIND_qmc) :: MIN_EDGE_THICKNESS = 1.2e-8_KIND_qmc
REAL(KIND_qmc) :: QMC_DEFAULT_TOL     = 10._KIND_qmc*EPSILON(1._KIND_qmc)
REAL(KIND_qmc) :: CWENO_cwt           = 1._KIND_qmc
REAL(KIND_qmc) :: CWENO_eps           = 1.E-4_KIND_qmc
INTEGER        :: CWENO_order         = 2
INTEGER        :: EdgeInterpolator    = QMC_PARABOLIC

!(make options public)
PUBLIC :: MIN_EDGE_THICKNESS
PUBLIC :: EdgeInterpolator,KEYS_EdgeInterpolator
PUBLIC :: CWENO_Cwt,CWENO_eps,CWENO_order
PUBLIC :: QMC_PARABOLICKARPOV

!!## PROCEDURES
CONTAINS

!!### FUNCTION <<qmc_ThinEdgeCount>>
FUNCTION qmc_ThinEdgeCount(init)
INTEGER :: qmc_ThinEdgeCount
LOGICAL,INTENT(IN),OPTIONAL :: init
!!--begin--
IF( PRESENT(init) )THEN
 IF( init )THEN
  COUNT_ThinEdges = 0
 END IF
END IF
qmc_ThinEdgeCount = COUNT_ThinEdges
!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB0>>
FUNCTION qmc_PsiSB0( s , t )

!!#### PURPOSE
!! Provide a basic interface to the <qmc_PsiSB>
!! function.

!!#### REQUIRED INPUT
REAL(KIND_qmc),INTENT(IN) :: s,t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB0

!!--begin--
qmc_PsiSB0 = qmc_PsiSB(slice_id,s,t)
!!--end--
END FUNCTION

!!### FUNCTION <<qmc_Q>>
FUNCTION qmc_Q( id , s , t )

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: s,t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_Q

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_Q = q1 + qs*s + qt*t

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB>>
FUNCTION qmc_PsiSB( id , s , t )

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: s,t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: ds,smin0,b0,coeff
REAL(KIND_qmc) :: x,x0,PM(0:1),PsiE,PsiS

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

ds    = MAX(smax2-smin2,smax1-smin1)
smin0 = qmc_smin(id,t)
b0    = (s-smin0)/ds

IF( sintheta==0._KIND_qmc )THEN
 x     = SQRT(HUGE(1._KIND_qmc))
 coeff = x
 x0    = ds*sigma*b0
ELSE
 x     = ds*sigma*b0/sintheta
 coeff = 1._KIND_qmc/sintheta
 x0    = ds*sigma*b0
END IF

!get the polymoment
CALL PolyExpoMoment( MaxN=1 , x=x , x0=x0 , c=coeff , PM=PM(0:1) , &
  tol=QMC_DEFAULT_TOL )

!get the easy E-component
PsiE = qmc_PsiSB_in(id,t)*EXP(-sigma*(s-smin0)/sintheta)

!get the constant, s and t parts of the S-component
PsiS = ds*b0*( (q1 + qs*b0*ds + qs*smin0 + qt*t)*PM(0) + &
               (   - qs*b0*ds                  )*PM(1) )

qmc_PsiSB = PsiS + PsiE

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_in>>
FUNCTION qmc_PsiSB_in(id,t)

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_in

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_PsiSB_in = a*(t**2) + b*t + c

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_out>>
FUNCTION qmc_PsiSB_out(id,t)

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_out

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

!![waw] this could be inlined later (instead of just
!! calling the <PsiSB(s,t)> function.)
qmc_PsiSB_out = qmc_PsiSB( id,qmc_smax(id,t) , t )

!!--end--
END FUNCTION

FUNCTION qmc_LenSliOut(id)
INTEGER,INTENT(IN) :: id
REAL(KIND_qmc) :: qmc_LenSliOut
INCLUDE "26-C-USR_SBCharacteristics.f90.sup"
qmc_LenSliOut = LenSliOut
END FUNCTION

FUNCTION qmc_LenSliIn(id)
INTEGER,INTENT(IN) :: id
REAL(KIND_qmc) :: qmc_LenSliIn
INCLUDE "26-C-USR_SBCharacteristics.f90.sup"
qmc_LenSliIn = LenSliIn
END FUNCTION

FUNCTION qmc_AreaSli(id)
INTEGER,INTENT(IN) :: id
REAL(KIND_qmc) :: qmc_AreaSli
INCLUDE "26-C-USR_SBCharacteristics.f90.sup"
qmc_AreaSli = AreaSli
END FUNCTIOn

!!### SUBROUTINE <<qmc_PRINT>>
SUBROUTINE qmc_PRINT(id,Unit)
USE VAR_Units           !!((03-A-VAR_Units.f90))
USE FUN_Default         !!((04-A-FUN_Default.f90))

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### OPTIONAL INPUT
INTEGER,INTENT(IN),OPTIONAL :: Unit

!!#### LOCAL VARIABLES
INTEGER :: Unit_
REAL(KIND_qmc) :: tm

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

Unit_ = Default( DEFAULT_OUTPUT_UNIT , Unit )
WRITE(Unit_,*)"--begin----------qmc_PRINT------------------------"
WRITE(Unit_,*)"Slice ID = ",slice_id
WRITE(Unit_,*)" "
WRITE(Unit_,*)"slice incoming flux expansion psiin(t) = a t**2 + b t + c"
WRITE(Unit_,*)"  a = ",a
WRITE(Unit_,*)"  b = ",b
WRITE(Unit_,*)"  c = ",c
WRITE(Unit_,*)" "
WRITE(Unit_,*)"Source function q(s,t) = q1 + qs s + qt t"
WRITE(Unit_,*)"  q1 = ",q1
WRITE(Unit_,*)"  qs = ",qs
WRITE(Unit_,*)"  qt = ",qt
WRITE(Unit_,*)" "
WRITE(Unit_,*)"Geometry Info"
WRITE(Unit_,*)"    t1,t2    = ",t1,t2
WRITE(Unit_,*)" smin1,smin2 = ",smin1,smin2
WRITE(Unit_,*)" smax1,smax2 = ",smax1,smax2
WRITE(Unit_,*)"  LenSliIn   = ",LenSliIn
WRITE(Unit_,*)"  LenSliOut  = ",LenSliOut
WRITE(Unit_,*)"   AreaSli   = ",AreaSli
WRITE(Unit_,*)" "
tm = (t1+t2)*0.5_KIND_qmc
WRITE(Unit_,*)"Consistency Checks"
WRITE(Unit_,*)" PsiIn diff t1",qmc_PsiSB_in(id,t1)-qmc_PsiSB(id,qmc_smin(id,t1),t1)
WRITE(Unit_,*)" PsiIn diff tm",qmc_PsiSB_in(id,tm)-qmc_PsiSB(id,qmc_smin(id,tm),tm)
WRITE(Unit_,*)" PsiIn diff t2",qmc_PsiSB_in(id,t2)-qmc_PsiSB(id,qmc_smin(id,t2),t2)
WRITE(Unit_,*)
WRITE(Unit_,*)"--end------------qmc_PRINT------------------------"

!!--end--
END SUBROUTINE

!!### FUNCTION <<qmc_CalcBalance>>
FUNCTION qmc_CalcBalance(id,tol,relerr)

!!#### PURPOSE
!! Return the integrated angular flux inside the slice.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_CalcBalance

!!#### OPTIONAL INPUT
REAL(KIND_qmc),OPTIONAL,INTENT(IN)  :: tol
REAL(KIND_qmc),OPTIONAL,INTENT(OUT) :: relerr

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: PsiE_out,PsiS_out,Psi_in,PsiE_int,PsiS_int
REAL(KIND_qmc) :: PsiEavg_out,PsiSavg_out,Psiavg_in,PsiEavg_int,PsiSavg_int
REAL(KIND_qmc) :: Psi_out,Psi_int,nout(2),nin(2)
REAL(KIND_qmc) :: Q_int,Qavg_int,Bal1,Bal2,PsiAvg_int,Psiavg_out
REAL(KIND_qmc) :: maxavg
!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

PsiE_int = PsiE_Interior_Para(PsiEavg_int,t1,t2,smin1,smin2,smax1,smax2,sigma,c ,b ,a ,sintheta,tol)
PsiS_int = PsiS_Interior_Lin (PsiSavg_int,t1,t2,smin1,smin2,smax1,smax2,sigma,q1,qs,qt,sintheta,tol)
Psi_int  = PsiE_int + PsiS_int
Psiavg_int  = PsiEavg_int + PsiSavg_int

PsiE_out = PsiE_Out_Para(PsiEavg_out,t1,t2,smin1,smin2,smax1,smax2,sigma,c ,b ,a ,sintheta,tol)
PsiS_out = PsiS_Out_Lin (PsiSavg_out,t1,t2,smin1,smin2,smax1,smax2,sigma,q1,qs,qt,sintheta,tol)
Psi_out  = PsiE_out + PsiS_out
Psiavg_out  = PsiEavg_out + PsiSavg_out

Psi_in    = qmc_PsiSB_IntIn(id,Psiavg_in)
Q_Int     = Q_Interior_Lin(Qavg_int,t1,t2,smin1,smin2,smax1,smax2,q1,qs,qt,tol)

Bal1 = Psi_out*sintheta  - Psi_in*sintheta + sigma*Psi_int - Q_Int
!get outedge and inedge normals
!nout = xyPERPCCW_U( xyDIRECTION_PP( (/t1,smax1/) , (/t2,smax2/) ) )
!nin  = xyPERPCW_U ( xyDIRECTION_PP( (/t1,smin1/) , (/t2,smin2/) ) )

!Bal2 = Psiavg_out*LenSliOut*nout(2)*sintheta + &
!       Psiavg_in *LenSliIn *nin (2)*sintheta + &
!      sigma*Psiavg_int*AreaSli - Qavg_int*AreaSli

qmc_CalcBalance=Bal1

IF( PRESENT(relerr) )THEN
 maxavg = MAXVAL(ABS( (/Psiavg_out,Psiavg_in,Qavg_int,Psiavg_int/)) )
 maxavg = MERGE(TINY(0._KIND_qmc),maxavg,maxavg==0._KIND_qmc)
 relerr = Bal1/maxavg
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_int>>
FUNCTION qmc_PsiSB_int(id,Avg,tol)

!!#### PURPOSE
!! Return the integrated angular flux inside the slice.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_int
REAL(KIND_qmc),INTENT(OUT) :: Avg

!!#### OPTIONAL INPUT
REAL(KIND_qmc),OPTIONAL,INTENT(IN) :: tol

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: PsiE,PsiS,PsiEavg,PsiSavg
!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

!get E- and S- component
PsiE = PsiE_Interior_Para(PsiEavg,t1,t2,smin1,smin2,smax1,smax2,sigma,c ,b ,a ,sintheta,tol)
PsiS = PsiS_Interior_Lin (PsiSavg,t1,t2,smin1,smin2,smax1,smax2,sigma,q1,qs,qt,sintheta,tol)

!combine
qmc_PsiSB_int = PsiE + PsiS
Avg           = PsiEavg+PsiSavg

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_intout>>
FUNCTION qmc_PsiSB_intout(id,Avg,tol)

!!#### PURPOSE
!! Return the integrated angular flux out of the slice.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_intout
REAL(KIND_qmc),INTENT(OUT) :: Avg

!!#### OPTIONAL INPUT
REAL(KIND_qmc),INTENT(IN),OPTIONAL :: tol

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: PsiS,PsiE,PsiEavg,PsiSavg

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

!get E-component and S-component
PsiE = PsiE_Out_Para(PsiEavg,t1,t2,smin1,smin2,smax1,smax2,sigma,c ,b ,a ,sintheta,tol)
PsiS = PsiS_Out_Lin (PsiSavg,t1,t2,smin1,smin2,smax1,smax2,sigma,q1,qs,qt,sintheta,tol)

!combine
qmc_PsiSB_intout = PsiE + PsiS
Avg              = PsiEavg+PsiSavg

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_intin>>
FUNCTION qmc_PsiSB_intin(id,Avg)

!!#### PURPOSE
!! Return the integrated angular flux into the slice.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_intin
REAL(KIND_qmc) :: Avg

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_PsiSB_intin = &
  a*(t2**3-t1**3)/3._KIND_qmc + &
  b*(t2**2-t1**2)/2._KIND_qmc + &
  c*(t2   -t1   )

Avg = qmc_PsiSB_intin/(t2-t1)

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_out1>>
FUNCTION qmc_PsiSB_out1(id)

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_out1

!!#### PURPOSE
!! Return the pointwise angular flux value out of the slice
!! at the left-most t-value, $t_1$.

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_PsiSB_out1 = qmc_PsiSB_out( id,t1 )

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiSB_out2>>
FUNCTION qmc_PsiSB_out2(id)

!!#### PURPOSE
!! Return the pointwise angular flux value out of the slice
!! at the right-most t-value, $t_2$.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_PsiSB_out2

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_PsiSB_out2 = qmc_PsiSB_out( id,t2 )

!!--end--
END FUNCTION

!!### SUBROUTINE <<qmc_INIT>>
SUBROUTINE qmc_INIT( id , Sli , psiin , q  , MacT , RecipSin )

!!#### PURPOSE
!! Initialize the variables needed for this subcell balance method
!! which operates on slices.

!!#### DETAILS
!! The incoming angular flux <psiin>, must already be converted to
!! $(s,t)$ coordinates---i.e. a function of $t$ only.  The
!! source must also be a function of $(s,t)$ coordinates.
!!
!! The <id> must be unique for each slice.  It is how we decide to use
!! cached data or to actually recalculate some value.

!!#### LOCAL MODULES
USE FUN_xyCENTROID      !!((05-B-FUN_xyCENTROID.f90))
USE FUN_xySAREA         !!((03-A-FUN_xySAREA.f90))

!!#### REQUIRED INPUT
!! * the id number for this slice <id>
!! * the slice <Sli>
!! * the incoming quadratic function <psiin>
!! * the total source within the slice <q>
!! * the macroscopic total cross section <MacT>
!! * the reciprocal of the $\sin(\theta)$
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: Sli(3,2)
REAL(KIND_qmc),INTENT(IN) :: psiin(3)
REAL(KIND_qmc),INTENT(IN) :: q(3)
REAL(KIND_qmc),INTENT(IN) :: MacT
REAL(KIND_qmc),INTENT(IN) :: RecipSin

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: SliQg(2,4),CSli(2),ASli

!!--begin--

!! Get the slice geometry.
t1    = Sli(1,1)
smin1 = Sli(2,1)
smax1 = Sli(3,1)
t2    = Sli(1,2)
smin2 = Sli(2,2)
smax2 = Sli(3,2)

!! length of incoming slice edge
LenSliIn  = SQRT( (t2-t1)**2 + (smin2-smin1)**2 )

!! length of outgoing slice edge
LenSliOut = SQRT( (t2-t1)**2 + (smax2-smax1)**2 )

!area of slice
AreaSli = 0.5_KIND_qmc*(smax1-smin1+smax2-smin2)*(t2-t1)

!! Get incoming angular flux variables <a,b,c>.
!! $$ \psi(t) = a t**2 + b t + c $$
!! Note the ordering of psiin (starts with constant term).
a     = psiin(3)
b     = psiin(2)
c     = psiin(1)

!! Get source variables <q1,qs,qt>.
!! $$ q(s,t) = q1 + q_s s + q_t t $$
q1    = q(1)
qs    = q(2)
qt    = q(3)

!translate to slice center
SliQg(:,1) = (/t1,smin1/)
SliQg(:,2) = (/t2,smin2/)
SliQg(:,3) = (/t2,smax2/)
SliQg(:,4) = (/t1,smax1/)
ASli = xySAREA_Pg( 4 , SliQg )
CSli = xyCENTROID_Pg( 4 , SliQg , AREA=ASli)
!q1    = q(1)+qs*CSli(2)+qt*CSli(1)

!set id
slice_id = id

!total cross section
sigma=mact

!sin(theta)
sintheta=1._KIND_qmc/RecipSin

!!--end--
END SUBROUTINE

FUNCTION qmc_Ds( id , t )

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_Ds

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_Ds = ((smax2-smin2)-(smax1-smin1))*((t-t1)/(t2-t1)) + smax1-smin1

!!--end--
END FUNCTION

FUNCTION qmc_Dt(id)

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_Dt

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_Dt = t2-t1

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_smax>>
FUNCTION qmc_smax(id,t)

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_smax

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

IF( IsThinEdge(id,LenSliOut,(/t1,t2/)) )THEN
 qmc_smax = (smax1+smax2)/2._KIND_qmc
ELSE
 qmc_smax = smax1 + (t-t1)*(smax2-smax1)/(t2-t1)
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_smin>>
FUNCTION qmc_smin(id,t)

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: t

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_smin

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

IF( IsThinEdge(id,LenSliIn,(/t1,t2/)) )THEN
 qmc_smin = (smin1+smin2)/2._KIND_qmc
ELSE
 qmc_smin = smin1 + (t-t1)*(smin2-smin1)/(t2-t1)
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_t1>>
FUNCTION qmc_t1(id)

!!#### PURPOSE
!! Return left side <t1>.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_t1

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_t1 = t1

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_t2>>
FUNCTION qmc_t2(id)

!!#### PURPOSE
!! Return right side <t2>.

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: id

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: qmc_t2

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

qmc_t2 = t2

!!--end--
END FUNCTION

!!### FUNCTION <<IsThinEdge>>
FUNCTION IsThinEdge(id,LenEdge,T)

!!#### PURPOSE
!! Check if the edge is thin.

!!#### REQUIRED INPUT
INTEGER       ,INTENT(IN) :: id
REAL(KIND_qmc),INTENT(IN) :: LenEdge,T(2)

!!#### REQUIRED OUTPUT
LOGICAL :: IsThinEdge

!!--begin--

INCLUDE "26-C-USR_SBCharacteristics.f90.sup"

IsThinEdge = ((T(2)-T(1)) <= MIN_EDGE_THICKNESS*LenEdge)

IF( IsThinEdge )THEN
 COUNT_ThinEdges = COUNT_ThinEdges + 1
END IF

!!--end--
END FUNCTION

!!### SUBROUTINE <<qmc_DiscontinuousFix>>
SUBROUTINE qmc_DiscontinuousFix( Sli , OutVert )
REAL(KIND_qmc),INTENT(IN) :: Sli(:,:)
INTEGER       ,INTENT(INOUT) :: OutVert(:)
REAL(KIND_qmc) :: DT,t1,t2
INTEGER :: n
!!--begin--
DT=Sli(1,SIZE(Sli,2))-Sli(1,1)

DO n=1,SIZE(OutVert)-1
 t1=Sli(1,n)
 t2=Sli(1,n+1)
 !vertex ''sharing'' for thin edges
 IF( qmc_ThinEdgeCheck(DT,(/t1,t2/)) )THEN
  IF( OutVert(n)==0 )THEN
   OutVert(n) = OutVert(n+1)
  ELSE IF( OutVert(n+1)==0 )THEN
   OutVert(n+1) = OutVert(n)
  END IF
 END IF
END DO
!!--end--
END SUBROUTINE

!!### FUNCTION <<qmc_ThinEdgeCheck>>
FUNCTION qmc_ThinEdgeCheck(LenEdge,T) RESULT(IsThinEdge)

!!#### PURPOSE
!! Check if the edge is thin, without updating
!! the thin edge count or requiring a passed <id>.

!!#### REQUIRED INPUT
REAL(KIND_qmc),INTENT(IN) :: LenEdge,T(2)

!!#### REQUIRED OUTPUT
LOGICAL :: IsThinEdge

!!--begin--

IsThinEdge = ((T(2)-T(1)) <= MIN_EDGE_THICKNESS*LenEdge)

!!--end--
END FUNCTION

!!### FUNCTION <<CWENO_Parabola_2Pt1Avg>>
FUNCTION CWENO_Parabola_2Pt1Avg(y1,y2,yavg,L,cwt,order,eps) RESULT(Para)

!!#### PURPOSE
!! Reconstruct a parabolic function according to
!! CWENO methodology.

!!#### MODULES
USE FUN_Default         !!((04-A-FUN_Default.f90))

!!#### REQUIRED INPUT
REAL(KIND_Rdp),INTENT(IN) :: y1,y2,yavg,L

!!#### OPTIONAL INPUT
REAL(KIND_Rdp),INTENT(IN),OPTIONAL :: cwt
INTEGER       ,INTENT(IN),OPTIONAL :: order
REAL(KIND_Rdp),INTENT(IN),OPTIONAL :: eps

!!#### REQUIRED OUTPUT
REAL(KIND_Rdp) :: Para(3)

!!#### LOCAL VARIABLES
REAL(KIND_Rdp) :: eps_,cwt_
INTEGER        :: p
REAL(KIND_Rdp) :: Ccenter,Cleft,Cright
REAL(KIND_Rdp) :: ISleft,ISright,IScenter
REAL(KIND_Rdp) :: acenter,aleft,aright,atot
REAL(KIND_Rdp) :: wcenter,wleft,wright
REAL(KIND_Rdp) :: fcenter(3),fright(3),fleft(3)

!!--begin--

eps_ = Default(1.E-4_KIND_qmc,eps)
p    = Default(2,order)
cwt_ = Default(0.5_KIND_qmc,cwt)

!must be between 0 and 1
CCenter = MIN(MAX(cwt_,0._KIND_qmc),1._KIND_qmc)

!the left side and right side weights are created as equal
!parts of (1-Ccenter).
Cleft  = (1._KIND_qmc-Ccenter)/2._KIND_qmc
Cright = Cleft

!the smoothness indicators follow from [ref]
ISleft   = 4._KIND_qmc*((y1 - yavg)**2)
ISright  = 4._KIND_qmc*((y2 - yavg)**2)
IScenter = ((3._KIND_qmc + Ccenter**2)*(y1**2) + &
            (3._KIND_qmc + Ccenter**2)*(y2**2) - &
             12._KIND_qmc*y2*yavg + &
             12._KIND_qmc*(yavg**2) - &
              2._KIND_qmc*y1*( &
                (-3._KIND_qmc + Ccenter**2)*y2 + &
                  6._KIND_qmc*yavg) )/(Ccenter**2)

!**in the above code, the substitution has already been made that
!Cleft=Cright=(1-Ccenter)/2 as it leads to much shorter code

!the unnormalized weights are
acenter = Ccenter/((eps_ + IScenter )**p)
aleft   = Cleft  /((eps_ +   ISleft )**p)
aright  = Cright /((eps_ +  ISright )**p)
atot    = (acenter+aleft+aright)

!the normalized weights are
wcenter = acenter/atot
wleft   = aleft/atot
wright  = aright/atot

!the parabolic polynomial functions are (1,x,x**2)
fleft   = (/ y1                         ,&
            (2._KIND_qmc/L)*(yavg - y1) ,&
             0._KIND_qmc                /)
fright  = (/ y2-2._KIND_qmc*(y2-yavg)   ,&
            (2._KIND_qmc/L)*(y2-yavg)   ,&
             0._KIND_qmc      /)
fcenter = (/ (L**2)*( (1 + Ccenter)*y1 - (-1._KIND_qmc + Ccenter)*(y2 - 2*yavg) ),&
            -2*L*((3 + Ccenter)*y1 + 3*y2 - Ccenter*y2 - 6*yavg)     ,&
             6*(y1 + y2 - 2*yavg)                                    /)
fcenter = fcenter/(2._KIND_qmc*Ccenter*(L**2))

!non-inlined version
!fopt = (/ y1                         , &
!         (-2*y2 - 4*y1 + 6*yavg)/(L) , &
!        ( 3*y1 + 3*y2 - 6*yavg)/(L**2) /)
!fcenter = (fopt-Cleft*fleft-Cright*fright)/Ccenter

Para = wleft*fleft + wright*fright + wcenter*fcenter

!!--end--
END FUNCTION

FUNCTION TEST_Karpov(Noisy) RESULT(Pass)
USE FUN_IsApprox        !!((03-A-FUN_IsApprox.f90))
USE FUN_Default         !!((04-A-FUN_Default.f90))
LOGICAL,INTENT(IN),OPTIONAL :: Noisy
REAL(KIND_Rdp) :: y1,y2,yavg,L,xbar,PPara(3,2),PPara_exact(3,2)
REAL(KIND_Rdp) :: xbar_exact
LOGICAL :: Pass
LOGICAL :: Noisy_

!!--begin--

Noisy_=Default(.TRUE.,Noisy)

!trial
y1    = 0.0_KIND_qmc
y2    = 1.0_KIND_qmc
yavg  = 0.999_KIND_qmc
L     = 1.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF

!test 0
y1    = 3.0_KIND_qmc
y2    = 4.0_KIND_qmc
yavg  = 3.02_KIND_qmc
L     = 3.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,2) = (/248.4444444444444_KIND_qmc,&
                     -174.0740740740741_KIND_qmc,&
                     30.86419753086420_KIND_qmc/)
PPara_exact(:,1) = (/3.0_KIND_qmc,0._KIND_qmc,0._KIND_qmc/)
xbar_exact=2.82_KIND_qmc
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test 1
y1    = 0.0_KIND_qmc
y2    = 1.0_KIND_qmc
yavg  = 0.5_KIND_qmc
L     = 2.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/0.0_KIND_qmc,0.5_KIND_qmc,0.0_KIND_qmc/)
xbar_exact = ERROR(xbar)
PPara_exact(:,2) = ERROR(xbar)
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test 2
y1    = 1.0_KIND_qmc
y2    = 0.0_KIND_qmc
yavg  = 0.5_KIND_qmc
L     = 2.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/1.0_KIND_qmc,-0.5_KIND_qmc,0.0_KIND_qmc/)
PPara_exact(:,2) = ERROR(xbar)
xbar_exact       = ERROR(xbar)
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test 3
y1    = 0.0_KIND_qmc
y2    = 1.0_KIND_qmc
yavg  = 0.5_KIND_qmc
L     = 10.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/0.0_KIND_qmc,0.1_KIND_qmc,0.0_KIND_qmc/)
xbar_exact=ERROR(xbar)
PPara_exact(:,2) = ERROR(xbar)
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test 4
y1    = 3.0_KIND_qmc
y2    = 4.0_KIND_qmc
yavg  = 3.98_KIND_qmc
L     = 3.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/3.000000000000000_KIND_qmc,&
                     11.11111111111111_KIND_qmc,&
                     -30.86419753086420_KIND_qmc/)
PPara_exact(:,2) = (/4.0_KIND_qmc,0._KIND_qmc,0._KIND_qmc/)
xbar_exact=0.18_KIND_qmc
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test 5
y1    = 4.0_KIND_qmc
y2    = 3.0_KIND_qmc
yavg  = 3.98_KIND_qmc
L     = 3.0_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/4.0_KIND_qmc,0._KIND_qmc,0._KIND_qmc/)
PPara_exact(:,2) = (/-241.4444444444444_KIND_qmc,&
                      174.0740740740741_KIND_qmc,&
                     -30.86419753086420_KIND_qmc/)
xbar_exact=2.82_KIND_qmc
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

!test6
L=8.5984014931059094233079566_KIND_qmc
y1=0.85428740709975122300311276_KIND_qmc
y2=8.3652615099894423023770088_KIND_qmc
yavg=2.6025922877436917132595828_KIND_qmc
PPara = PParaInterpolant_Karpov(y1,y2,yavg,L,xbar)
IF( Noisy_ )THEN
 CALL PRINT_PPara(xbar,PPara,L)
END IF
PPara_exact(:,1) = (/0.85428740709975122300311276_KIND_qmc,0._KIND_qmc,0._KIND_qmc/)
PPara_exact(:,2) = (/2.256332617604223130637754_KIND_qmc,&
                     -1.080934197326799193858458_KIND_qmc,&
                     0.2083418441496121988928199_KIND_qmc/)
xbar_exact=2.594136098148796220973967_KIND_qmc
Pass = IsApprox((/xbar,PPara/),(/xbar_exact,PPara_exact/))
IF( .NOT.Pass )GOTO 666

666 CONTINUE

!!--end--
END FUNCTION

!!### SUBROUTINE <<GNUPLOT_PPara>>
SUBROUTINE GNUPLOT_PPara( xbar,PPara,L,fname)
REAL(KIND_Rdp),INTENT(IN) :: xbar,PPara(3,2),L
CHARACTER(*),INTENT(IN),OPTIONAL :: fname
CHARACTER(4) :: fname_
IF( PRESENT(fname) )THEN
  fname_=fname
ELSE
  fname_='f'
END IF
!!--begin--
IF( IsError(xbar) )THEN
    WRITE(*,'(a,3(a,e10.3))')TRIM(fname_),"(x) = ",PPara(3,1),"*x**2 + ",PPara(2,1),"*x + ",PPara(1,1)
ELSE
    WRITE(*,'(a,1(a,es12.5),a)')TRIM(fname_),"(x) = x < ",xbar," ? \"
    WRITE(*,'(3(a,es12.5),a)')"      ",PPara(3,1),"*x**2 + ",PPara(2,1),"*x + ",PPara(1,1)," : \"
    WRITE(*,'(3(a,es12.5),a)')"      ",PPara(3,2),"*x**2 + ",PPara(2,2),"*x + ",PPara(1,2),";"
END IF

!!--end--
END SUBROUTINE

!!### SUBROUTINE <<PRINT_PPara>>
SUBROUTINE PRINT_PPara( xbar,PPara,L)
REAL(KIND_Rdp),INTENT(IN) :: xbar,PPara(3,2),L
!!--begin--
WRITE(*,*)" xbar=",xbar
WRITE(*,*)" ax**2+bx+c, x<xbar"
WRITE(*,*)" a=",PPara(3,1)
WRITE(*,*)" b=",PPara(2,1)
WRITE(*,*)" c=",PPara(1,1)
WRITE(*,*)" ax**2+bx+c, x>=xbar"
WRITE(*,*)" a=",PPara(3,2)
WRITE(*,*)" b=",PPara(2,2)
WRITE(*,*)" c=",PPara(1,2)

!!--end--
END SUBROUTINE

!!### FUNCTION <<PParaInterpolant_Karpov>>
FUNCTION PParaInterpolant_Karpov(y1,y2,yavg,L,xbar) RESULT(PPara)
!!#### PURPOSE
!! Construct a piecewise parabolic polynomial interpolant of
!! two endpoint values and an average value.

!!#### REQUIRED INPUT
REAL(KIND_Rdp),INTENT(IN) :: y1,y2,yavg,L

!!#### REQUIRED OUTPUT
REAL(KIND_Rdp),INTENT(OUT) :: xbar
REAL(KIND_Rdp) :: PPara(3,2)

!!#### LOCAL VARIABLES
REAL(KIND_Rdp) :: ymin,ymax,r,dy,lstarl,lstarr
LOGICAL :: Noisy_=.FALSE.

!!--begin--

xbar = ERROR(xbar)
PPara = ERROR(xbar)

ymin = MIN(y1,y2)
ymax = MAX(y1,y2)

IF( yavg>=ymax )THEN
 !possibly non-monotonic (parabola based on ymax only)
 PPara(1,1) = ymax
 PPara(2,1) = (-6*ymax + 6*yavg)/(L)
 PPara(3,1) = ( 6*ymax - 6*yavg)/(L**2)
 IF( Noisy_ )THEN
    WRITE(*,*)"WARNING: discontinuous yavg>=ymax interpolant used."
 END IF

ELSE IF( yavg<=ymin )THEN
 !possibly non-monotonic (parabola based on ymin only)
 PPara(1,1) = ymin
 PPara(2,1) = (-6*ymin + 6*yavg)/(L)
 PPara(3,1) = ( 6*ymin - 6*yavg)/(L**2)
 IF( Noisy_ )THEN
    WRITE(*,*)"WARNING: discontinuous yavg<=ymin interpolant used."
 END IF

ELSE
 !monotonic

 !if we have a dy that vanishes
 dy = y2-y1

 IF( dy==0._KIND_qmc )THEN
  PPara(1,1) = y1
  PPara(2,1) = 0._KIND_qmc
  PPara(3,1) = 0._KIND_qmc

 !dy is normal
 ELSE

  !get the left lstar
  lstarl =     3*L*(y2-yavg)/(y2-y1)
  !get the right lstar
  lstarr = L - 3*L*(y1-yavg)/(y1-y2)
!   WRITE(*,*)'lstarl=',lstarl
!   WRITE(*,*)'lstarr=',lstarr
!   WRITE(*,*)'L=',L
!   WRITE(*,*)'y1=',y1
!   WRITE(*,*)'y2=',y2
!   WRITE(*,*)'yavg=',yavg
!   WRITE(*,*)'dy=',dy
  IF( 0._KIND_qmc<lstarl .AND. lstarl<L )THEN
   !use left piecewise parabolic
   r = (y2 - y1)/(lstarl**2)     !evaluate at l=lstarl
   PPara(1,1) = y1               !y1
   PPara(2,1) = 2*r*lstarl       !2*y2-2*y1
   PPara(3,1) = -r               !y1-y2
   PPara(1,2) = y2               !=y2 as it should
   PPara(2,2) = 0._KIND_qmc
   PPara(3,2) = 0._KIND_qmc
   xbar = lstarl

  ELSE IF( 0._KIND_qmc<lstarr .AND. lstarr<L )THEN
   !use right piecewise parabolic
   !y1 + 2*(y2-y1)*l/lstarl + (y1-y2)*(l/lstarl)**2
   !
   !l->(L-l)
   !lstarl->(L-lstarr)
   !y1 + 2*(y2-y1)*(L-l)/(L-lstarr) + (y1-y2)*((L-l)/(L-lstarr))**2
   !y1 + 2*(y2-y1)*L/(L-lstarr) + (y1-y2)*L**2/(L-lstarr))**2 + = y1 + (y2-y1)*2*L*(L-lstarr)/(L-lstarr)**2 - (y2-y1)*L**2/(L-lstarr)**2 = y1+(y1-y2)*(2*lstarr*L-L**2)/(L-lstarr)**2
   !2*(y1-y2)*l*(L-lstarr)/(L-lstarr)**2 - 2*(y1-y2)*l*L/(L-lstarr)**2 + = -2*(y1-y2)*lstarr*L/(L-lstarr)**2
   !(y1-y2)*l**2/(L-lstarr)**2
   r = (y1 - y2)/((L-lstarr)**2)
   PPara(1,1) = y1
   PPara(2,1) = 0._KIND_qmc
   PPara(3,1) = 0._KIND_qmc              !evaluate at l=lstarr
   PPara(1,2) = y1 - r*lstarr**2         !y1 - r*lstarr**2
   PPara(2,2) = 2*r*lstarr               !2*r*lstarr**2
   PPara(3,2) = -r                       !-r*lstarr**2 ---> y1
   xbar = lstarr                         !at L
                                         !y1 - r*(L**2-2*lstarr*L+lstarr**2)=y1-r*(L-lstarr)**2 = y2
  ELSE
   !use center parabolic
   PPara(1,1) = y1
   PPara(2,1) = (-2*y2 - 4*y1 + 6*yavg)/(L)
   PPara(3,1) = ( 3*y1 + 3*y2 - 6*yavg)/(L**2)

  END IF

 END IF

END IF

!!--end--
END FUNCTION

!!### FUNCTION <<PParaInterpolant_Karpov2>>
FUNCTION PParaInterpolant_Karpov2(y1,y2,yavg,L,xbar,ccenter,p,eps) RESULT(PPara)
!!#### PURPOSE
!! Construct a piecewise parabolic polynomial interpolant of
!! two endpoint values and an average value.

!!#### REQUIRED INPUT
REAL(KIND_Rdp),INTENT(IN) :: y1,y2,yavg,L

!!#### REQUIRED OUTPUT
REAL(KIND_Rdp),INTENT(OUT) :: xbar
REAL(KIND_Rdp) :: PPara(3,2)

!!#### OPTIONAL INPUT
REAL(KIND_Rdp) :: ccenter,eps
INTEGER        :: p

!!#### LOCAL VARIABLES
REAL(KIND_Rdp) :: ymin,ymax,r,dy,lstarl,lstarr
REAL(KIND_Rdp) :: PParaC(3,2),Cleft,Cright
REAL(KIND_Rdp) :: aleft,aright,acenter
REAL(KIND_Rdp) :: ISleft,ISright,IScenter
REAL(KIND_Rdp) :: wleft,wright,wcenter

!!--begin--

xbar = ERROR(xbar)
PPara = ERROR(xbar)

ymin = MIN(y1,y2)
ymax = MAX(y1,y2)

IF( yavg>=ymax )THEN
 !possibly non-monotonic (parabola based on ymax only)
 WRITE(*,*)"non-monotonic with ymax"
 PPara(1,1) = ymax
 PPara(2,1) = (-6*ymax + 6*yavg)/(L)
 PPara(3,1) = ( 6*ymax - 6*yavg)/(L**2)

ELSE IF( yavg<=ymin )THEN
 !possibly non-monotonic (parabola based on ymin only)
 WRITE(*,*)"non-monotonic with ymin"
 PPara(1,1) = ymin
 PPara(2,1) = (-6*ymin + 6*yavg)/(L)
 PPara(3,1) = ( 6*ymin - 6*yavg)/(L**2)

ELSE
 !monotonic

 !if we have a dy that vanishes
 dy = y2-y1

 IF( dy==0._KIND_qmc )THEN
  PPara(1,1) = y1
  PPara(2,1) = 0._KIND_qmc
  PPara(3,1) = 0._KIND_qmc

 !dy is normal
 ELSE

  !get the left lstar
  lstarl = L*(3*y2      - 3*yavg)/dy

  !get the right lstar
  lstarr = L*(2*y1 + y2 - 3*yavg)/dy

  !**in the above code, the substitution has already been made that
  Cright=(1-Ccenter)/2._KIND_Rdp
  Cleft=Cright
  ISleft  = (lstarl)**2
  ISright = (L-lstarr)**2
  IScenter = ((3._KIND_qmc + Ccenter**2)*(y1**2) + &
              (3._KIND_qmc + Ccenter**2)*(y2**2) - &
             12._KIND_qmc*y2*yavg + &
             12._KIND_qmc*(yavg**2) - &
              2._KIND_qmc*y1*( &
                (-3._KIND_qmc + Ccenter**2)*y2 + &
                  6._KIND_qmc*yavg) )/(Ccenter**2)

  !the unnormalized weights are
  acenter = Ccenter/((eps + IScenter )**p)
  aleft   = Cleft  /((eps +   ISleft )**p)
  aright  = Cright /((eps +  ISright )**p)

  IF( aleft>aright )THEN
   !use left piecewise parabolic
   r = (y2 - y1)/(lstarl**2)
   PPara(1,1) = y2 - r*lstarl**2
   PPara(2,1) = 2*r*lstarl
   PPara(3,1) = -r
   PPara(1,2) = y2
   PPara(2,2) = 0._KIND_qmc
   PPara(3,2) = 0._KIND_qmc
   xbar = lstarl

   !center parabolic
   PParaC(1,1) = y1
   PParaC(2,1) = (-2*y2 - 4*y1 + 6*yavg)/(L)
   PParaC(3,1) = ( 3*y1 + 3*y2 - 6*yavg)/(L**2)
   PParaC(1,2) = PParaC(1,1) -   PParaC(2,1)*lstarl + PParaC(3,1)*lstarl**2
   PParaC(2,2) = PParaC(2,1) - 2*PParaC(3,1)*lstarl
   PParaC(3,2) = PParaC(3,1)

   !the normalized weights are
   wcenter = acenter/(acenter+aleft)
   wleft   = aleft  /(acenter+aleft)
   PPara = PPara*wleft + PParaC*wcenter

  ELSE
   !use right piecewise parabolic
   r = (y1 - y2)/((L-lstarr)**2)
   PPara(1,1) = y1
   PPara(2,1) = 0._KIND_qmc
   PPara(3,1) = 0._KIND_qmc
   PPara(1,2) = y1 - r*lstarr**2
   PPara(2,2) = 2*r*lstarr
   PPara(3,2) = -r
   xbar = lstarr

   !center parabolic
   PParaC(1,1) = y1
   PParaC(2,1) = (-2*y2 - 4*y1 + 6*yavg)/(L)
   PParaC(3,1) = ( 3*y1 + 3*y2 - 6*yavg)/(L**2)
   PParaC(1,2) = PParaC(1,1) -   PParaC(2,1)*lstarr + PParaC(3,1)*lstarr**2
   PParaC(2,2) = PParaC(2,1) - 2*PParaC(3,1)*lstarr
   PParaC(3,2) = PParaC(3,1)

   !the normalized weights are
   wcenter = acenter/(acenter+aright)
   wright  = aright /(acenter+aright)
   PPara = PPara*wright + PParaC*wcenter

  END IF

 END IF

END IF

!!--end--
END FUNCTION

!!!### FUNCTION <<PParaInterpolant_Karpov3>>
!FUNCTION PParaInterpolant_Karpov3(y1,y2,yavg,L,xbar) RESULT(PPara)
!!!#### PURPOSE
!!! Construct a piecewise parabolic polynomial interpolant of
!!! two endpoint values and an average value, using a more
!!! robust algorithm than PParaInterpolant_Karpov.
!
!!!#### REQUIRED INPUT
!REAL(KIND_Rdp),INTENT(IN) :: y1,y2,yavg,L
!
!!!#### REQUIRED OUTPUT
!REAL(KIND_Rdp),INTENT(OUT) :: xbar
!REAL(KIND_Rdp) :: PPara(3,2)
!
!!!#### LOCAL VARIABLES
!REAL(KIND_Rdp) :: ymin,ymax,dy,lstarl,lstarr
!REAL(KIND_Rdp) :: y1_,y2_,yavg_,dy_,dyL_,dyR_
!
!!!--begin--
!
!xbar = ERROR(xbar)
!PPara = ERROR(xbar)
!
!
!ymin = MIN(y1,y2)
!ymax = MAX(y1,y2)
!
!IF( yavg>=ymax )THEN
! !possibly non-monotonic (parabola based on ymax only)
! PPara(1,1) = ymax
! PPara(2,1) = (-6*ymax + 6*yavg)/(L)
! PPara(3,1) = ( 6*ymax - 6*yavg)/(L**2)
!
!ELSE IF( yavg<=ymin )THEN
! !possibly non-monotonic (parabola based on ymin only)
! PPara(1,1) = ymin
! PPara(2,1) = (-6*ymin + 6*yavg)/(L)
! PPara(3,1) = ( 6*ymin - 6*yavg)/(L**2)
!
!ELSE
! !monotonic
!
! !if we have a dy that vanishes
! dy = y2-y1
!
! IF( dy==0._KIND_qmc )THEN
!  PPara(1,1) = y1
!  PPara(2,1) = 0._KIND_qmc
!  PPara(3,1) = 0._KIND_qmc
!
! !dy is normal
! ELSE
!
!  !change to normalized space
!  y1_ = y1/ymax
!  y2_ = y2/ymax
!  yavg_ = yavg/ymax
!  dy_ = y2_ - y1_
!
!  !get the left lstar
!  lstarl = L*(3*y2_      - 3*yavg_)/dy_
!  !get the right lstar
!  lstarr = L*(2*y1_ + y2_ - 3*yavg_)/dy_
!
!  IF( 0._KIND_qmc<lstarl .AND. lstarl<L )THEN
!   dyL_ = y2_-yavg_
!   !use left piecewise parabolic
!   PPara(1,1) = y1_
!   PPara(2,1) =  (2.d0/3.d0) * (dy_)**2 / ((L*dyL_)   )
!   PPara(3,1) = -(1.d0/9.d0) * (dy_)**3 / ((L*dyL_)**2)
!   PPara(1,2) = y2_
!   PPara(2,2) = 0._KIND_qmc
!   PPara(3,2) = 0._KIND_qmc
!   xbar = lstarl
!   PPara = PPara*ymax
!  ELSE IF( 0._KIND_qmc<lstarr .AND. lstarr<L )THEN
!   dyR_ = y1_-yavg_
!   !use right piecewise parabolic
!   PPara(1,1) = y1_
!   PPara(2,1) = 0._KIND_qmc
!   PPara(3,1) = 0._KIND_qmc
!   PPara(1,2) = y2_ + (1.d0/9.d0)*(dy_**2)*(6*dyR_-5*dy_)/((dy_-dyR_)**2)
!   PPara(2,2) = (2.d0/9.d0)*(dy_**2)*(2*dy_-3*dyR_)/(L*(dy_-dyR_)**2)
!   PPara(3,2) = (1.d0/9.d0)*(dy_**3)/(L**2*(dy_-dyR_)**2)
!   xbar = lstarr
!   PPara = PPara*ymax
!  ELSE
!   !use center parabolic
!   PPara(1,1) = y1_
!   PPara(2,1) = (-2*y2_ - 4*y1_ + 6*yavg_)/(L)
!   PPara(3,1) = ( 3*y1_ + 3*y2_ - 6*yavg_)/(L**2)
!   PPara(:,1) = PPara(:,1)*ymax
!  END IF
!
!
! END IF
!
!END IF
!
!!!--end--
!END FUNCTION

!!### FUNCTION <<qmc_Q_FROM_QXY>>
FUNCTION qmc_Q_FROM_QXY( es , QXY , corig , crot ) RESULT(Q)

!!#### PURPOSE
!! Transform a source in (x,y) coordinates to (s,t) coordinates.

!!#### REQUIRED INPUT
REAL(KIND_qmc),INTENT(IN) :: es(2),QXY(3)
REAL(KIND_qmc),INTENT(IN),OPTIONAL :: corig(3),crot(3) !additional mapping params

!!#### REQUIRED OUTPUT
REAL(KIND_qmc) :: q(3)

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: et(2)
REAL(KIND_qmc) :: dx_ds,dx_dt,dy_ds,dy_dt,alpha

!!--begin--

 !constant
 q(1) = QXY(1)

IF( .NOT.(PRESENT(crot).AND.PRESENT(corig)) )THEN
 !s-direction (travel direction--projected to xy-plane)
 q(2) = es(1)*QXY(2) + es(2)*QXY(3)

 !t-direction (perpendicular to s)
 q(3) = es(2)*QXY(2) - es(1)*QXY(3)
ELSE

 !s-direction (travel direction--projected to xy-plane)
 q(2) = es(1)*QXY(2) + es(2)*QXY(3)

 !t-direction (perpendicular to s)
 q(3) = es(2)*QXY(2) - es(1)*QXY(3)

 dx_ds = corig(1)/crot(2)
 dy_ds = corig(2)/crot(2)
 dx_dt = corig(1)/crot(1)
 dy_dt = corig(2)/crot(1)
 alpha = corig(3)

 !s-direction (travel direction--projected to xy-plane)
 q(2) = ( ( es(1)*dx_ds - alpha*es(2)*dx_dt )*QXY(2) + &
          ( es(2)*dy_ds + alpha*es(1)*dy_dt )*QXY(3) )/(1.d0-alpha**2)

 !t-direction (perpendicular to s)
 q(3) =  ( ( es(2)*dx_dt - alpha*es(1)*dx_ds )*QXY(2) + &
           (-es(1)*dy_dt - alpha*es(2)*dy_ds )*QXY(3) )/(1.d0-alpha**2)

 !s-direction (travel direction--projected to xy-plane)
 q(2) = es(1)*QXY(2) + es(2)*QXY(3)

 !t-direction (perpendicular to s)
 q(3) = es(2)*QXY(2) - es(1)*QXY(3)

END IF
!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiInOut_from_PsiEdge>>
FUNCTION qmc_PsiInOut_from_PsiEdge( PsiEdge , LenEdge , T , &
  PsiAvg , tvals ) RESULT(PsiInOut)

!!#### PURPOSE
!! Convert a parabolic function representation on an edge ($\ell$
!! coordinates) to the slice edge ($t$ coordinates).

!!#### DETAILS
!! The conversion centers around the following expression
!!
!! $$ \ell(t) = \frac{t-T_1}{T_2-T_1} L      \quad \ell \in [0,L] $$
!!
!! and the inverse
!!
!! $$ t(\ell) = T_1 + \frac{\ell}{L} (T_2-T_1) \quad t \in [T_1,T_2]. $$
!!
!! This $T_1$ and $T_2$ are not the same as the $t_1$ and $t_2$
!! that form the bounds for a slice.  These are for a whole edge.

!!#### REQUIRED INPUT
!! * the 1D parabolic edge function for $\ell \in [0,L]$
!      PsiEdge(1) + PsiEdge(2) * l + PsiEdge(3)* l**2
!! * the length of the edge $L=$<LenEdge>
!! * the t-bounds of the EDGE (not slice)
REAL(KIND_qmc),INTENT(IN) :: PsiEdge(3)
REAL(KIND_qmc),INTENT(IN) :: LenEdge
REAL(KIND_qmc),INTENT(IN) :: T(2)
REAL(KIND_qmc),INTENT(IN) :: PsiAvg

!!#### OPTIONAL INPUT/OUTPUT
!! * input $\ell$ values to map out to $t$ values
REAL(KIND_qmc),INTENT(INOUT),OPTIONAL :: tvals(:)

!!#### REQUIRED OUTPUT
!! * the 1D parabolic edge function for $t \in [t1,t2]$
!      PsiInOut(1) + PsiInOut(2) * t + PsiInOut(3) * t**2
REAL(KIND_qmc) :: PsiInOut(3)

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: Dt,LdivDt1,LdivDt2,Lm
INTEGER :: i

!!--begin--

!get some convenience variables
Dt = T(2) - T(1)

!set the output
IF( Dt<=MIN_EDGE_THICKNESS*LenEdge )THEN
 !we have some options for slices which are almost parallel
 !to direction of travel

 !0. assume constant and equal to average
 PsiInOut(1) = PsiAvg
 !1. assume constant and equal to midpoint value
 !Lm = LenEdge*0.5_KIND_qmc
 !PsiInOut(1) = PsiEdge(1) + PsiEdge(2)*Lm + PsiEdge(3)*(Lm**2)
 !2. assume constant and equal to arithmetic average of left and right
 !PsiInOut(1) = 0.5_KIND_qmc*( 2*PsiEdge(1)              + &
 !                               PsiEdge(2)*LenEdge      + &
 !                               PsiEdge(3)*(LenEdge**2) )
 !3. assume constant and equal to left endpoint
 !PsiInOut(1) = PsiEdge(1)
 !4. assume constant and equal to right endpoint
 !PsiInOut(1) = PsiEdge(1) + PsiEdge(2)*LenEdge + PsiEdge(3)*(LenEdge**2)
 PsiInOut(2) = 0._KIND_qmc
 PsiInOut(3) = 0._KIND_qmc
ELSE
 LdivDt1 = LenEdge/Dt
 LdivDt2 = LdivDt1**2
 PsiInOut(1) = PsiEdge(1) - (T(1))*PsiEdge(2)*LdivDt1 +   (T(1)**2)*PsiEdge(3)*LdivDt2
 PsiInOut(2) =                     PsiEdge(2)*LdivDt1 - 2*(T(1)   )*PsiEdge(3)*LdivDt2
 PsiInOut(3) =                                                      PsiEdge(3)*LdivDt2
END IF

IF( PRESENT(tvals) )THEN
 DO i=1,SIZE(tvals)
  IF( .NOT.IsError(tvals(i)) )THEN
   tvals(i) = T(1) + (tvals(i)/LenEdge) * (Dt)
  END IF
 END DO
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiEdge_from_2Pt1Avg>>
FUNCTION qmc_PsiEdge_from_2Pt1Avg( PsiAvg , LenEdge , &
  Psi1 , Psi2 , HasExtrema , Extrema ) RESULT(PsiEdge)

!!#### PURPOSE
!! Convert 3 values of the outgoing edge to a parabolic function.

!!#### REQUIRED INPUT
!! * the average over an outgoing edge <PsiAvg>
!! * the length of the edge $L=$<LenEdge>
!! * the point values at the left and right <Psi1> and <Psi2>
REAL(KIND_qmc),INTENT(IN) :: PsiAvg
REAL(KIND_qmc),INTENT(IN) :: LenEdge
REAL(KIND_qmc),INTENT(IN) :: Psi1
REAL(KIND_qmc),INTENT(IN) :: Psi2

!!#### REQUIRED OUTPUT
!! * the 1D parabolic edge function for $\ell \in [0,L]$
!      PsiEdge(1) + PsiEdge(2) * \ell + PsiEdge(3) * \ell**2
REAL(KIND_qmc) :: PsiEdge(3)

!!#### OPTIONAL OUTPUT
!! * whether or not there is an extrema in the region
LOGICAL       ,INTENT(OUT),OPTIONAL :: HasExtrema
REAL(KIND_qmc),INTENT(OUT),OPTIONAL :: Extrema

!!#### LOCAL VARIABLES
REAL(KIND_qmc) :: ellstar

!!--begin--

IF( PRESENT(Extrema) )THEN
 Extrema = Error(Extrema)
END IF

SELECT CASE(EdgeInterpolator)
 CASE(QMC_PARABOLIC)
  !parabolic interpolant
  PsiEdge(3) = ( 3*Psi1 - 6*PsiAvg + 3*Psi2 )/LenEdge**2
  PsiEdge(2) = (-4*Psi1 + 6*PsiAvg - 2*Psi2 )/LenEdge
  PsiEdge(1) = Psi1

 CASE(QMC_LINEAREDGES)
  !linear interpolant variant which satisfies edge values
  PsiEdge(3) = 0._KIND_qmc
  PsiEdge(2) = (Psi2-Psi1)/LenEdge
  PsiEdge(1) = Psi1

 CASE(QMC_LINEARAVERAGE)
  !linear interpolant variant which satisfies average value
  PsiEdge(3) = 0._KIND_qmc
  PsiEdge(2) = (Psi2-Psi1)/LenEdge
  PsiEdge(1) = PsiAvg - 0.5_KIND_qmc*(Psi2-Psi1)

 CASE(QMC_FLAT)
  !flat interpolant
  PsiEdge(3) = 0._KIND_qmc
  PsiEdge(2) = 0._KIND_qmc
  PsiEdge(1) = PsiAvg

 CASE(QMC_CWENO)
  !centered WENO-based interpolant
  PsiEdge = CWENO_Parabola_2Pt1Avg(Psi1,Psi2,PsiAvg,LenEdge,&
            CWENO_cwt,CWENO_order,CWENO_eps)

 CASE DEFAULT
  WRITE(*,*)"Fatal Error: NO EDGE INTERPOLATOR SET!"
  STOP

END SELECT

IF( PRESENT(HasExtrema) )THEN
 IF( PsiEdge(3)==0._KIND_qmc )THEN
  ellstar = -LenEdge
 ELSE
  ellstar = -PsiEdge(2)/(2*PsiEdge(3))
 END IF
 HasExtrema = (0._KIND_qmc<=ellstar .AND. ellstar<=LenEdge)
 IF( PRESENT(Extrema) )THEN
  IF( HasExtrema )THEN
   Extrema = ellstar
  END IF
 END IF
END IF

!!--end--
END FUNCTION

!!### FUNCTION <<qmc_PsiEdge2_from_2Pt1Avg>>
FUNCTION qmc_PsiEdge2_from_2Pt1Avg( PsiAvg , LenEdge , &
  Psi1 , Psi2 , lstar , HasExtrema , Extrema ) RESULT(PsiEdge2)

!!#### PURPOSE
!! Convert 3 values of the outgoing edge to a
!! piecewise parabolic interpolator function.
!
! the function is piecewise continuous in C_0 and C_1
!
! for 0     <= l <= lstar : PsiEdge2(:,1)
! for lstar <  l <= L     : PsiEdge2(:,2)
!
! where c=PsiEdge2(1,i)
!       b=PsiEdge2(2,i)
!       a=PsiEdge2(3,i)
! in the function y(l) = al**2 + bl + c
!
USE FUN_IsError         !!((05-A-FUN_IsError.f90))

!!#### CHANGES
!! v0.03 - removed part of the piecewise if lstar is too small.

!!#### REQUIRED INPUT
!! * the average over an outgoing edge <PsiAvg>
!! * the length of the edge $L=$<LenEdge>
!! * the point values at the left and right <Psi1> and <Psi2>
REAL(KIND_qmc),INTENT(IN) :: PsiAvg
REAL(KIND_qmc),INTENT(IN) :: LenEdge
REAL(KIND_qmc),INTENT(IN) :: Psi1
REAL(KIND_qmc),INTENT(IN) :: Psi2

!!#### REQUIRED OUTPUT
!! * the 1D parabolic edge functions for $\ell \in [0,L]$
!      PsiEdge(1,i) + PsiEdge(2,i) * \ell + PsiEdge(3,i) * \ell**2
!! * the $\ell$ value at which we switch from i=1 to i=2
REAL(KIND_qmc)             :: PsiEdge2(3,2)
REAL(KIND_qmc),INTENT(OUT) :: lstar

!!#### OPTIONAL OUTPUT
!! * whether or not there is an extrema in the region
LOGICAL       ,INTENT(OUT),OPTIONAL :: HasExtrema
REAL(KIND_qmc),INTENT(OUT),OPTIONAL :: Extrema

!!--begin--

IF( EdgeInterpolator==QMC_PARABOLICKARPOV )THEN
 !CAUTION: this routine sometimes returns parabolics dominated by roundoff errors
 !hopefully v0.03 is fixing it
 PsiEdge2 = PParaInterpolant_Karpov(Psi1,Psi2,PsiAvg,LenEdge,lstar)
 IF( ABS(lstar/LenEdge)<=MIN_EDGE_THICKNESS )THEN
    PsiEdge2(1  ,1)=Psi1
    PsiEdge2(2:3,1)=0._KIND_qmc
 ELSEIF( ABS(lstar/LenEdge-1.d0)<=MIN_EDGE_THICKNESS )THEN
    PsiEdge2(1  ,2)=Psi2
    PsiEdge2(2:3,2)=0._KIND_qmc
 END IF

ELSE
 lstar = ERROR(lstar)
 PsiEdge2(:,1) = ERROR(lstar)
 PsiEdge2(:,2) = qmc_PsiEdge_from_2Pt1Avg( PsiAvg , LenEdge , &
  Psi1 , Psi2 , HasExtrema , Extrema )
END IF

!!--end--
END FUNCTION

END MODULE


!*==clauum.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLAUUM + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDA, N
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLAUUM computes the product U * U**H or L**H * L, where the triangular
!> factor U or L is stored in the upper or lower triangular part of
!> the array A.
!>
!> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!> overwriting the factor U in A.
!> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!> overwriting the factor L in A.
!>
!> This is the blocked form of the algorithm, calling Level 3 BLAS.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the triangular factor stored in the array A
!>          is upper or lower triangular:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the triangular factor U or L.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the triangular factor U or L.
!>          On exit, if UPLO = 'U', the upper triangle of A is
!>          overwritten with the upper triangle of the product U * U**H;
!>          if UPLO = 'L', the lower triangle of A is overwritten with
!>          the lower triangle of the product L**H * L.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE CLAUUM(Uplo,N,A,Lda,Info)
      IMPLICIT NONE
!*--CLAUUM106
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Lda , N
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E+0)
      COMPLEX CONE
      PARAMETER (CONE=(1.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER i , ib , nb
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      EXTERNAL LSAME , ILAENV
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEMM , CHERK , CLAUU2 , CTRMM , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CLAUUM',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Determine the block size for this environment.
!
      nb = ILAENV(1,'CLAUUM',Uplo,N,-1,-1,-1)
!
      IF ( nb<=1 .OR. nb>=N ) THEN
!
!        Use unblocked code
!
         CALL CLAUU2(Uplo,N,A,Lda,Info)
!
!        Use blocked code
!
      ELSEIF ( upper ) THEN
!
!           Compute the product U * U**H.
!
         DO i = 1 , N , nb
            ib = MIN(nb,N-i+1)
            CALL CTRMM('Right','Upper','Conjugate transpose','Non-unit',&
     &                 i-1,ib,CONE,A(i,i),Lda,A(1,i),Lda)
            CALL CLAUU2('Upper',ib,A(i,i),Lda,Info)
            IF ( i+ib<=N ) THEN
               CALL CGEMM('No transpose','Conjugate transpose',i-1,ib,  &
     &                    N-i-ib+1,CONE,A(1,i+ib),Lda,A(i,i+ib),Lda,    &
     &                    CONE,A(1,i),Lda)
               CALL CHERK('Upper','No transpose',ib,N-i-ib+1,ONE,       &
     &                    A(i,i+ib),Lda,ONE,A(i,i),Lda)
            ENDIF
         ENDDO
      ELSE
!
!           Compute the product L**H * L.
!
         DO i = 1 , N , nb
            ib = MIN(nb,N-i+1)
            CALL CTRMM('Left','Lower','Conjugate transpose','Non-unit', &
     &                 ib,i-1,CONE,A(i,i),Lda,A(i,1),Lda)
            CALL CLAUU2('Lower',ib,A(i,i),Lda,Info)
            IF ( i+ib<=N ) THEN
               CALL CGEMM('Conjugate transpose','No transpose',ib,i-1,  &
     &                    N-i-ib+1,CONE,A(i+ib,i),Lda,A(i+ib,1),Lda,    &
     &                    CONE,A(i,1),Lda)
               CALL CHERK('Lower','Conjugate transpose',ib,N-i-ib+1,ONE,&
     &                    A(i+ib,i),Lda,ONE,A(i,i),Lda)
            ENDIF
         ENDDO
      ENDIF
!
!
!     End of CLAUUM
!
      END SUBROUTINE CLAUUM


      Program receptor_raster

      implicit none

      Character(50) simid, name_mp !! name of simulation case, stations (name_mp)
      character(10) name_var
      integer nx, ny, nmp, idnum_rec  !! number of subgrid cells, monitor stations, and receptor # (=total number of stations+1)
      double precision x_mp,y_mp,y_rec,x_rec  !! (x,y,z) of receptor points and monitor stations
      double precision z_mp, z_rec
      double precision dx,dy   !! grid size (m) of receptor subgrid (usually 100m)
      double precision xsw_main,ysw_main  !! sw corner of main grid
      integer rcmax !! max distance of a source to the receptor point, set as -9900 (missing)
      integer i,j

      write(*,*) "Generate receptor raster file"

      open(unit=10,file="./receptor_input.txt")  !! open input file to define receptor raster geometry
      read(10,10) name_var, simid
      write(*,10) name_var, simid
      read(10,20) name_var, nmp
      write(*,20) name_var, nmp
      read(10,20) name_var, nx
      write(*,20) name_var, nx
      read(10,20) name_var, ny
      write(*,20) name_var, ny
      read(10,30) name_var, dx
      write(*,30) name_var, dx
      read(10,30) name_var, dy
      write(*,30) name_var, dy
      read(10,30) name_var, z_rec  !! height of receptor (same for all receptors)
      write(*,30) name_var, z_rec
      read(10,30) name_var, xsw_main  !! south-west corner of main grid (UTM, @m)
      write(*,30) name_var, xsw_main
      read(10,30) name_var, ysw_main  !! south-west corner of main grid (UTM, @m)
      write(*,30) name_var, ysw_main
      read(10,20) name_var, rcmax  !! max distance of a source to the receptor point, set as -9900 (missing)
      write(*,20) name_var, rcmax

      open(unit=20,file="../INPUT/receptor_stations_raster.txt")

      write(20,11) simid
      write(20,12) dx,dy
      write(20,13)

      ! KFL: The following codes are not working, set nstation = 0
      nmp = 0
      if (nmp .ge. 1) then    !!! reading the monitor station information
      do i=1,nmp
         read (10,60) name_var, x_mp,y_mp,z_mp,name_mp
         write(20,61) simid,x_mp,y_mp,z_mp,rcmax,name_mp
      enddo
      endif

      idnum_rec=nmp

      if (nx .ge. 1 .and. ny .ge. 1) then
      do j=1,ny
!         write(*,*) "calculate receptor location for", j
         if(j .eq. 1) y_rec=ysw_main+0.5*dy
         if(j .gt. 1) y_rec=y_rec+dy
         do i=1,nx
            if(i .eq. 1) x_rec=xsw_main+0.5*dx
            if(i .gt. 1) x_rec=x_rec+dx
            idnum_rec=idnum_rec+1

            write (20,62) simid, x_rec,y_rec,z_rec,rcmax,idnum_rec
         enddo
      enddo
      endif

      close (10)
      close (20)

   10 format(a10,a50)
   11 format(a50)
   12 format('* Dummy Receptor points for ',f8.1,' x ',f8.1,'m2 raster grid')
   13 format('*                                   GUID         X         Y       Z   NUMPERSONS NAME')
   20 format(a10,i8)
   30 format(a10,f15.1)  !!! for reading location values
   60 format(a10,2f10.1,f8.1,a50) !! reading station information
   61 format(a40,2f10.1,f8.1,i8,2X, a50) !! reading station information
   62 format(a40,2f10.1,f8.1,2i8) !! reading station information

      end program


module interquantity_test
    use quaff, only: &
            operator(*), &
            operator(/), &
            operator(-), &
            operator(+), &
            operator(.unit.), &
            as_burnup, &
            CUBIC_METERS, &
            JOULES, &
            JOULES_PER_KELVIN_MOL, &
            JOULES_PER_KILOGRAM, &
            JOULES_PER_MOL, &
            DELTA_KELVIN, &
            KELVIN, &
            KILOGRAMS, &
            KILOGRAMS_PER_CUBIC_METER, &
            KILOGRAMS_PER_MOL, &
            METERS, &
            METERS_PER_SECOND, &
            METERS_PER_SQUARE_SECOND, &
            MOLS, &
            NEWTONS, &
            PASCAL_SECONDS, &
            PASCALS, &
            PER_KELVIN, &
            SECONDS, &
            SQUARE_METERS, &
            WATT_SECONDS_PER_KILOGRAM, &
            WATTS
    use quaff_asserts_m, only: assert_equals
    use veggies, only: result_t, test_item_t, describe, it, assert_equals

    implicit none
    private
    public :: test_interquantity_operators
contains
    function test_interquantity_operators() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "multiplying or dividing different quantities and subtracting temperatures", &
                [ it( &
                        "2 m * 3 m = 6 m^2", check_length_times_length) &
                , it( &
                        "6 m^2 / 3 m = 2 m", check_area_divided_by_length) &
                , it( &
                        "2 m^2 * 3 m = 6 m^3", check_area_times_length) &
                , it( &
                        "2 m * 3 m^2 = 6 m^3", check_length_times_area) &
                , it( &
                        "6 m^3 / 3 m^2 = 2 m", check_volume_divided_by_area) &
                , it( &
                        "6 m^3 / 3 m = 2 m^2", check_volume_divided_by_length) &
                , it( &
                        "6 kg / 3 m^3 = 2 kg/m^3", check_mass_divided_by_volume) &
                , it( &
                        "2 kg/m^3 * 3 m^3 = 6 kg", check_density_times_volume) &
                , it( &
                        "2 m^3 * 3 kg/m^3 = 6 kg", check_volume_times_density) &
                , it( &
                        "6 kg / 3 kg/m^3 = 2 m^3", check_mass_divided_by_density) &
                , it( &
                        "6 m / 3 s = 2 m/s", check_length_divided_by_time) &
                , it( &
                        "2 m/s * 3 s = 6 m", check_speed_times_time) &
                , it( &
                        "2 s * 3 m/s = 6 m", check_time_times_speed) &
                , it( &
                        "6 m / 3 m/s = 2 s", check_length_divided_by_speed) &
                , it( &
                        "6 m/s / 3 s = 2 m/s^2", check_speed_divided_by_time) &
                , it( &
                        "2 m/s^2 * 3 s = 6 m/s", check_acceleration_times_time) &
                , it( &
                        "2 s * 3 m/s^2 = 6 m/s", check_time_times_acceleration) &
                , it( &
                        "6 m/s / 3 m/s^2 = 2 s", check_speed_divided_by_acceleration) &
                , it( &
                        "2 kg * 3 m/s^2 = 6 N", check_mass_times_acceleration) &
                , it( &
                        "2 m/s^2 * 3 kg = 6 N", check_acceleration_times_mass) &
                , it( &
                        "6 N / 3 m/s^2 = 2 kg", check_force_divided_by_acceleration) &
                , it( &
                        "6 N / 3 kg = 2 m/s^2", check_force_divided_by_mass) &
                , it( &
                        "6 N / 3 m^2 = 2 Pa", check_force_divided_by_area) &
                , it( &
                        "2 Pa * 3 m^2 = 6 N", check_pressure_times_area) &
                , it( &
                        "2 m^2 * 3 Pa = 6 N", check_area_times_pressure) &
                , it( &
                        "6 N / 3 Pa = 2 m^2", check_force_divided_by_pressure) &
                , it( &
                        "2 N * 3 m = 6 J", check_force_times_length) &
                , it( &
                        "2 m * 3 N = 6 J", check_length_times_force) &
                , it( &
                        "6 J / 3 N = 2 m", check_energy_divided_by_force) &
                , it( &
                        "6 J / 3 m = 2 N", check_energy_divided_by_length) &
                , it( &
                        "6 J / 3 s = 2 W", check_energy_divided_by_time) &
                , it( &
                        "2 W * 3 s = 6 J", check_power_times_time) &
                , it( &
                        "2 s * 3 W = 6 J", check_time_times_power) &
                , it( &
                        "6 J / 3 W = 2 s", check_energy_divided_by_power) &
                , it( &
                        "2 Pa * 3 s = 6 Pa s", check_pressure_times_time) &
                , it( &
                        "2 s * 3 Pa = 6 Pa s", check_time_times_pressure) &
                , it( &
                        "6 Pa s / 3 s = 2 Pa", check_dynamic_viscosity_divided_by_time) &
                , it( &
                        "6 Pa s / 3 Pa = 2 s", check_dynamic_viscosity_divided_by_pressure) &
                , it( &
                        "6 J / 3 kg = 2 J/kg", check_energy_divided_by_mass) &
                , it( &
                        "2 J/kg * 3 kg = 6 J", check_enthalpy_times_mass) &
                , it( &
                        "2 kg * 3 J/kg = 6 J", check_mass_times_enthalpy) &
                , it( &
                        "6 J / 3 J/kg = 2 kg", check_energy_divided_by_enthalpy) &
                , it( &
                        "6 kg / 3 mol = 2 kg/mol", check_mass_divided_by_amount) &
                , it( &
                        "2 kg/mol * 3 mol = 6 kg", check_molar_mass_times_amount) &
                , it( &
                        "2 mol * 3 kg/mol = 6 kg", check_amount_times_molar_mass) &
                , it( &
                        "6 kg / 3 kg/mol = 2 mol", check_mass_divided_by_molar_mass) &
                , it( &
                        "2 (W s)/kg * 3 kg = 6 J", check_burnup_times_mass) &
                , it( &
                        "2 kg * 3 (W s)/kg = 6 J", check_mass_times_burnup) &
                , it( &
                        "6 J / 3 (W s)/kg = 2 kg", check_energy_divided_by_burnup) &
                , it( &
                        "2 J/kg = 2 (W s)/kg", check_enthalpy_to_burnup) &
                , it( &
                        "2 Pa * 3 m^3 = 6 J", check_pressure_times_volume) &
                , it( &
                        "2 m^3 * 3 Pa = 6 J", check_volume_times_pressure) &
                , it( &
                        "2 J/(K mol) * 3 K = 6 J/mol", check_energy_per_temperature_amount_times_temperature) &
                , it( &
                        "2 K * 3 J/(K mol) = 6 J/mol", check_temperature_times_energy_per_temperature_amount) &
                , it( &
                        "6 J / 3 J/mol = 2 mol", check_energy_divided_by_energy_per_amount) &
                , it( &
                        "3 /K * 2 K = 6.0", check_thermal_expansion_times_delta_temp) &
                , it( &
                        "1 K - 1 k = 0 K", check_temp_diff_gives_delta_temperature) &
                , it( &
                        "1 K + 1 k = 2 K", check_temperature_plus_delta_temperature) &
                ])
    end function test_interquantity_operators

    pure function check_length_times_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.SQUARE_METERS, &
                (2.0d0.unit.METERS) * (3.0d0.unit.METERS))
    end function

    pure function check_area_divided_by_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS, &
                (6.0d0.unit.SQUARE_METERS) / (3.0d0.unit.METERS))
    end function

    pure function check_area_times_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.CUBIC_METERS, &
                (2.0d0.unit.SQUARE_METERS) * (3.0d0.unit.METERS))
    end function

    pure function check_length_times_area() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.CUBIC_METERS, &
                (2.0d0.unit.METERS) * (3.0d0.unit.SQUARE_METERS))
    end function

    pure function check_volume_divided_by_area() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS, &
                (6.0d0.unit.CUBIC_METERS) / (3.0d0.unit.SQUARE_METERS))
    end function

    pure function check_volume_divided_by_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SQUARE_METERS, &
                (6.0d0.unit.CUBIC_METERS) / (3.0d0.unit.METERS))
    end function

    pure function check_mass_divided_by_volume() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.KILOGRAMS_PER_CUBIC_METER, &
                (6.0d0.unit.KILOGRAMS) / (3.0d0.unit.CUBIC_METERS))
    end function

    pure function check_density_times_volume() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.KILOGRAMS, &
                (2.0d0.unit.KILOGRAMS_PER_CUBIC_METER) * (3.0d0.unit.CUBIC_METERS))
    end function

    pure function check_volume_times_density() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.KILOGRAMS, &
                (2.0d0.unit.CUBIC_METERS) * (3.0d0.unit.KILOGRAMS_PER_CUBIC_METER))
    end function

    pure function check_mass_divided_by_density() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.CUBIC_METERS, &
                (6.0d0.unit.KILOGRAMS) / (3.0d0.unit.KILOGRAMS_PER_CUBIC_METER))
    end function

    pure function check_length_divided_by_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS_PER_SECOND, &
                (6.0d0.unit.METERS) / (3.0d0.unit.SECONDS))
    end function

    pure function check_speed_times_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.METERS, &
                (2.0d0.unit.METERS_PER_SECOND) * (3.0d0.unit.SECONDS))
    end function

    pure function check_time_times_speed() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.METERS, &
                (2.0d0.unit.SECONDS) * (3.0d0.unit.METERS_PER_SECOND))
    end function

    pure function check_length_divided_by_speed() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SECONDS, &
                (6.0d0.unit.METERS) / (3.0d0.unit.METERS_PER_SECOND))
    end function

    pure function check_speed_divided_by_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS_PER_SQUARE_SECOND, &
                (6.0d0.unit.METERS_PER_SECOND) / (3.0d0.unit.SECONDS))
    end function

    pure function check_acceleration_times_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.METERS_PER_SECOND, &
                (2.0d0.unit.METERS_PER_SQUARE_SECOND) * (3.0d0.unit.SECONDS))
    end function

    pure function check_time_times_acceleration() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.METERS_PER_SECOND, &
                (2.0d0.unit.SECONDS) * (3.0d0.unit.METERS_PER_SQUARE_SECOND))
    end function

    pure function check_speed_divided_by_acceleration() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SECONDS, &
                (6.0d0.unit.METERS_PER_SECOND) / (3.0d0.unit.METERS_PER_SQUARE_SECOND))
    end function

    pure function check_mass_times_acceleration() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.NEWTONS, &
                (2.0d0.unit.KILOGRAMS) * (3.0d0.unit.METERS_PER_SQUARE_SECOND))
    end function

    pure function check_acceleration_times_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.NEWTONS, &
                (2.0d0.unit.METERS_PER_SQUARE_SECOND) * (3.0d0.unit.KILOGRAMS))
    end function

    pure function check_force_divided_by_acceleration() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.KILOGRAMS, &
                (6.0d0.unit.NEWTONS) / (3.0d0.unit.METERS_PER_SQUARE_SECOND))
    end function

    pure function check_force_divided_by_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS_PER_SQUARE_SECOND, &
                (6.0d0.unit.NEWTONS) / (3.0d0.unit.KILOGRAMS))
    end function

    pure function check_force_divided_by_area() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.PASCALS, &
                (6.0d0.unit.NEWTONS) / (3.0d0.unit.SQUARE_METERS))
    end function

    pure function check_pressure_times_area() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.NEWTONS, &
                (2.0d0.unit.PASCALS) * (3.0d0.unit.SQUARE_METERS))
    end function

    pure function check_area_times_pressure() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.NEWTONS, &
                (2.0d0.unit.SQUARE_METERS) * (3.0d0.unit.PASCALS))
    end function

    pure function check_force_divided_by_pressure() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SQUARE_METERS, &
                (6.0d0.unit.NEWTONS) / (3.0d0.unit.PASCALS))
    end function

    pure function check_force_times_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.NEWTONS) * (3.0d0.unit.METERS))
    end function

    pure function check_length_times_force() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.METERS) * (3.0d0.unit.NEWTONS))
    end function

    pure function check_energy_divided_by_force() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.METERS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.NEWTONS))
    end function

    pure function check_energy_divided_by_length() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.NEWTONS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.METERS))
    end function

    pure function check_energy_divided_by_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.WATTS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.SECONDS))
    end function

    pure function check_power_times_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.WATTS) * (3.0d0.unit.SECONDS))
    end function

    pure function check_time_times_power() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.SECONDS) * (3.0d0.unit.WATTS))
    end function

    pure function check_energy_divided_by_power() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SECONDS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.WATTS))
    end function

    pure function check_pressure_times_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.PASCAL_SECONDS, &
                (2.0d0.unit.PASCALS) * (3.0d0.unit.SECONDS))
    end function

    pure function check_time_times_pressure() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.PASCAL_SECONDS, &
                (2.0d0.unit.SECONDS) * (3.0d0.unit.PASCALS))
    end function

    pure function check_dynamic_viscosity_divided_by_time() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.PASCALS, &
                (6.0d0.unit.PASCAL_SECONDS) / (3.0d0.unit.SECONDS))
    end function

    pure function check_dynamic_viscosity_divided_by_pressure() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.SECONDS, &
                (6.0d0.unit.PASCAL_SECONDS) / (3.0d0.unit.PASCALS))
    end function

    pure function check_energy_divided_by_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.JOULES_PER_KILOGRAM, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.KILOGRAMS))
    end function

    pure function check_enthalpy_times_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.JOULES_PER_KILOGRAM) * (3.0d0.unit.KILOGRAMS))
    end function

    pure function check_mass_times_enthalpy() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.KILOGRAMS) * (3.0d0.unit.JOULES_PER_KILOGRAM))
    end function

    pure function check_energy_divided_by_enthalpy() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.KILOGRAMS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.JOULES_PER_KILOGRAM))
    end function

    pure function check_mass_divided_by_amount() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.KILOGRAMS_PER_MOL, &
                (6.0d0.unit.KILOGRAMS) / (3.0d0.unit.MOLS))
    end function

    pure function check_molar_mass_times_amount() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.KILOGRAMS, &
                (2.0d0.unit.KILOGRAMS_PER_MOL) * (3.0d0.unit.MOLS))
    end function

    pure function check_amount_times_molar_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.KILOGRAMS, &
                (2.0d0.unit.MOLS) * (3.0d0.unit.KILOGRAMS_PER_MOL))
    end function

    pure function check_mass_divided_by_molar_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.MOLS, &
                (6.0d0.unit.KILOGRAMS) / (3.0d0.unit.KILOGRAMS_PER_MOL))
    end function

    pure function check_burnup_times_mass() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.WATT_SECONDS_PER_KILOGRAM) * (3.0d0.unit.KILOGRAMS))
    end function

    pure function check_mass_times_burnup() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.KILOGRAMS) * (3.0d0.unit.WATT_SECONDS_PER_KILOGRAM))
    end function

    pure function check_energy_divided_by_burnup() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.KILOGRAMS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.WATT_SECONDS_PER_KILOGRAM))
    end function

    pure function check_enthalpy_to_burnup() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.WATT_SECONDS_PER_KILOGRAM, &
                as_burnup(2.0d0.unit.JOULES_PER_KILOGRAM))
    end function

    pure function check_pressure_times_volume() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.PASCALS) * (3.0d0.unit.CUBIC_METERS))
    end function

    pure function check_volume_times_pressure() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES, &
                (2.0d0.unit.CUBIC_METERS) * (3.0d0.unit.PASCALS))
    end function

    pure function check_energy_per_temperature_amount_times_temperature() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES_PER_MOL, &
                (2.0d0.unit.JOULES_PER_KELVIN_MOL) * (3.0d0.unit.DELTA_KELVIN))
    end function

    pure function check_temperature_times_energy_per_temperature_amount() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0.unit.JOULES_PER_MOL, &
                (2.0d0.unit.DELTA_KELVIN) * (3.0d0.unit.JOULES_PER_KELVIN_MOL))
    end function

    pure function check_energy_divided_by_energy_per_amount() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.0d0.unit.MOLS, &
                (6.0d0.unit.JOULES) / (3.0d0.unit.JOULES_PER_MOL))
    end function

    pure function check_thermal_expansion_times_delta_temp() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                6.0d0, &
                (3.0d0.unit.PER_KELVIN) * (2.0d0.unit.DELTA_KELVIN))
    end function

    pure function check_temp_diff_gives_delta_temperature() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                0.d0.unit.DELTA_KELVIN, &
                (1.0d0.unit.KELVIN) - (1.0d0.unit.KELVIN))
    end function

    pure function check_temperature_plus_delta_temperature() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                2.d0.unit.KELVIN, &
                (1.0d0.unit.KELVIN) + (1.0d0.unit.DELTA_KELVIN))
    end function
end module


module BiConjugateGradientM

  use UtilitiesM
  use SparseKit

  use IterativeLinearSolverM

  implicit none

  private
  public :: BiConjugateGradientDT

  type, extends(IterativeLinearSolverDT) :: BiConjugateGradientDT
   contains
     procedure :: solveSystem => method
  end type BiConjugateGradientDT

contains

  subroutine method(this, vector, matrix, solution, arg)
    implicit none
    class(BiConjugateGradientDT), intent(inout)  :: this
    class(Sparse)               , intent(inout)  :: matrix
    real(rkind)   , dimension(:), intent(inout)  :: vector
    real(rkind)   , dimension(:), intent(inout)  :: solution
    integer(ikind), dimension(:), intent(inout)  :: arg
    real(rkind)   , dimension(:), allocatable    :: y, p, r, z
    integer(ikind), dimension(:), allocatable    :: spRowptr, spIdx, x_fixIdx
    real(rkind)   , dimension(:), allocatable    :: spMtx, x
    real(rkind)   , dimension(:), allocatable    :: b, diagMtx, x_fix
    real(rkind)    :: tol, err_old, err_new, alfa, beta, py
    integer(ikind) :: npoin, nfix, k
    integer(ikind) :: i, j
    npoin = matrix%getn()
    spMtx = matrix%getA()
    spIdx = matrix%getAJ()
    spRowptr = matrix%getAI()
    allocate(diagMtx(npoin))
    x = solution
    nfix = 0
    do i = 1, npoin
       if (sqrt(x(i)**2) .ne. 0.d0) then
          nfix = nfix + 1
       end if
    end do
    allocate(x_fixIdx(nfix), x_fix(nfix))
    do i = 1, npoin
       if (sqrt(x(i)**2) .ne. 0.d0) then
          x_fix(i) = x(i)
          x_fixIdx(i) = i
       end if
    end do
    b = vector
    do i = 1, npoin
       do j = spRowptr(i), spRowptr(i+1)-1
          if (i == spIdx(j)) then
             diagMtx = spMtx(j)
          end if
       end do
    end do
    allocate(y(npoin))
    allocate(p(npoin))
    allocate(r(npoin))
    allocate(z(npoin))
    k = 0
    tol = 1.d-10
    call copy1(nfix, 1.d0, x_fix, x_fixIdx, npoin, x)
    call SpMV(spMtx, spIdx, spRowptr, x, y, npoin, spRowptr(npoin+1))
    call copy2(npoin, 1.d30, x, nfix, x_fixIdx, y)
    call vecsum(npoin, -1.d0, y, b, r)
    call assign2(npoin, r, nfix, x_fixIdx, 0.d0)
    if(vecdot(npoin, r, r) < tol) return
    call vecdiv(npoin, r, diagMtx, p)
    err_new = vecdot(npoin, r, p)
    call SpMV(spMtx, spIdx, spRowptr, p, y, npoin, spRowptr(npoin+1))
    call copy2(npoin, 1.d30, p, nfix, x_fixIdx, y)
    py = vecdot(npoin, p, y)
    !DEBUGGGGG
    alfa = err_new/py
    call vecsum(npoin, alfa, p, x, x)
    err_old = err_new
    do while(dabs(err_old) > tol .and. k < 1000)
       k = k + 1
       call vecsum(npoin, -alfa, y, r, r)
       call vecdiv(npoin, r, diagMtx, z)
       err_new = vecdot(npoin, r, z)
       beta = err_new/err_old
       call vecsum(npoin, beta, p, z, p)
       call SpMV(spMtx, spIdx, spRowptr, p, y, npoin, spRowptr(npoin+1))
       call copy2(npoin, 1.d30, p, nfix, x_fixIdx, y)
       py = vecdot(npoin, p, y)
       !DEBUGGGGG
       alfa = err_new/py
       call vecsum(npoin, alfa, p, x, x)
       err_old = err_new
    end do
    solution = x
    return
  end subroutine method

  subroutine vecdiv(n, x, y, z)
    !---------------------------------
    !		Calcula z = x/y
    !---------------------------------
    implicit none
    integer(ikind) :: n, i
    real(rkind)    :: x(n), y(n), z(n)
    !$OMP PARALLEL DO
    do i = 1, n
       z(i) = x(i)/y(i)
    end do
    !$OMP END PARALLEL DO
  end subroutine vecdiv

  subroutine vecsum(n, alfa, x, y, z)
    !-----------------------------------
    !		Calcula z = alfa*x + y
    !-----------------------------------
    implicit none
    integer(ikind) :: n, i
    real(rkind)    :: x(n), y(n), z(n), alfa
    !$OMP PARALLEL DO
    do i = 1, n
       z(i) = alfa*x(i) + y(i)
    end do
    !$OMP END PARALLEL DO
  end subroutine vecsum

  subroutine assign(n, y, scal)
    !-----------------------------
    !		y(:) = scal
    !-----------------------------
    implicit none
    integer(ikind) :: n, i
    real(rkind)    :: scal, y(n)
    !$OMP PARALLEL DO PRIVATE(i)
    do i = 1, n
       y(i) = scal
    end do
    !$OMP END PARALLEL DO
  end subroutine assign

  subroutine assign2(n, y, m, idx, scal)
    implicit none
    integer(ikind) :: n, m, i
    real(rkind)    :: y(n), scal
    integer(ikind) :: idx(m)
    !$OMP PARALLEL DO PRIVATE(i)
    do i = 1, m
       y(idx(i)) = scal
    end do
    !$OMP END PARALLEL DO
  end subroutine assign2

  subroutine copy1(m, alfa, x, idx, n, y)
    !-----------------------------------------
    !			y(idx(:)) = alfa*x
    !-----------------------------------------
    implicit none
    integer(ikind) :: n, m, i
    real(rkind)    :: x(m), y(n), alfa
    integer(ikind) :: idx(m)
    !$OMP PARALLEL DO PRIVATE(i)
    do i=1, m
       y(idx(i)) = alfa*x(i)
    end do
    !$OMP END PARALLEL DO
  end subroutine copy1

  subroutine copy2(n, alfa, x, m, idx, y)
    !-----------------------------------------
    !			y(idx(:)) = alfa*x(idx(:))
    !-----------------------------------------
    implicit none
    integer(ikind) :: n, m, i
    real(rkind)    :: x(n), y(n), alfa
    integer(ikind) :: idx(m)
    !$OMP PARALLEL DO PRIVATE(i)
    do i=1, m
       y(idx(i)) = alfa*x(idx(i))
    end do
    !$OMP END PARALLEL DO
  end subroutine copy2

  real(8) function vecdot(n, x, y)
    !-----------------------------------
    !	Devuelve producto punto <x,y>
    !-----------------------------------
    implicit none
    integer(ikind) :: n, i
    real(rkind)    :: x(n), y(n), res
    res = 0.d0
    !$OMP PARALLEL DO REDUCTION(+:res)
    do i = 1, n
       res = res + x(i)*y(i)
    end do
    !$OMP END PARALLEL DO
    vecdot = res
  end function vecdot

  subroutine SpMV(spMtx, spIdx, spRowptr, v, y, npoin, npos)
    !---------------------------------------------------------
    !			Multiplicacion sparse y = M.v
    !---------------------------------------------------------
    implicit none
    integer(ikind) :: npoin, npos
    integer(ikind) :: i, j
    real(rkind)    :: spMtx(npos), v(npoin), y(npoin), dot
    integer(ikind) :: spIdx(npos), spRowptr(npoin+1)
    !$OMP PARALLEL DO PRIVATE(i, j, dot)
    do i = 1, npoin
       dot = 0.d0
       do j = spRowptr(i)+1, spRowptr(i+1)
          dot = dot + spMtx(j)*v(spIdx(j))
       end do
       y(i) = dot
    end do
    !$OMP END PARALLEL DO
  end subroutine SpMV

end module BiConjugateGradientM


! This demo program reads the naca6403_Re20k.csv and writes it to
! an output file naca6403_Re20k.C81. Both files are in the Samples/ directory.

program demo2

  use libC81
  implicit none

  integer, parameter :: rows = 19
  integer, parameter :: cols = 4
  integer, parameter :: nMach = cols-1
  integer :: i,j

  type(C81_class) :: C81
  real, dimension(rows,cols) :: A

  ! Read airfoil data from CSV file
  A=getTable('Samples/NACA6409.csv',rows,cols)

  ! Allocate arrays
  allocate(C81%MaL(nMach))
  allocate(C81%MaD(nMach))
  allocate(C81%MaM(nMach))
  allocate(C81%AL(rows-1))
  allocate(C81%AD(rows-1))
  allocate(C81%AM(rows-1))
  allocate(C81%CL(rows-1,nMach))
  allocate(C81%CD(rows-1,nMach))
  allocate(C81%CM(rows-1,nMach))

  ! Specify airfoil name
  C81%airfoilName = 'NACA6409'

  ! Copy values from read array to variables
  C81%MaL = A(1,2:)
  C81%MaD = C81%MaL
  C81%MaM = C81%MaL

  C81%AL = A(2:,1)
  C81%AD = C81%AL
  C81%AM = C81%AL

  do j=2,cols
    do i=2,rows
      C81%CL(i-1,j-1) = A(i,j)
    enddo
  enddo

  C81%CD = C81%CL
  C81%CM = C81%CL

  ! Write airfoil data to C81 file
  call c81%writefile('Samples/NACA6409.C81')

end program demo2