*
*     -------------------------------------------------------------
*      S I X J 2
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
*                                                                  *
*     | J/2  K/2  L/2 |                                            *
*     | M/2  N/2   2  |             [B.M.X. 75]                    *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
*
      SUBROUTINE SIXJ2(J,K,L,M,N,ITIK,SI)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      SI=ZERO
      IF(ITIK.NE.0) THEN
C
C     CHESKED TRIANGULAR CONDITIONS
C
        IF(IXJTIK(J,K,L,M,N,4).EQ.0)RETURN
      ENDIF
      I1=(J+K+L)/2
      AS=DBLE(I1)
      A=DBLE(L)
      B=DBLE(J)
      C=DBLE(K)
      AKA=ONE
      IF(MOD(I1,2).NE.0)AKA=-AKA
      IF(J-N.EQ.4) THEN
* -2
        IF(K-M.EQ.4) THEN
C  I                      -2  -2
      SI=AKA*DSQRT((AS-TWO)*(AS-ONE)*AS*(AS+ONE)/
     :((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
      SI=SI*DSQRT((AS-A-THREE)*(AS-A-TWO)*(AS-A-ONE)*(AS-A)/
     :((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.4) THEN
C  V   P(12)               2  -2
      SI=AKA*DSQRT((AS-C-THREE)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :((C+ONE)*(C+TWO)*(C+THREE)*(C+FOUR)*(C+TWO+THREE)))
      SI=SI*DSQRT((AS-B+ONE)*(AS-B+TWO)*(AS-B+THREE)*(AS-B+FOUR)/
     :((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(K-M.EQ.2) THEN
C  II   P(12)              -1   -2
      SI=AKA*TWO*DSQRT((AS-ONE)*AS*(AS+ONE)/
     :((C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
      SI=SI*DSQRT((AS-A-TWO)*(AS-A-ONE)*(AS-A)*(AS-C)*(AS-B+ONE)/
     :((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(M-K.EQ.2) THEN
C  IV   P(12)               1   -2
      SI=AKA*TWO*DSQRT((AS+ONE)*(AS-A)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :(C*(C+ONE)*(C+TWO)*(C+THREE)*(C+FOUR)))
      SI=SI*DSQRT((AS-B+ONE)*(AS-B+TWO)*(AS-B+THREE)/
     :((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
        ELSEIF(K-M.EQ.0) THEN
C  III  P(12)               0   -2
      SI=AKA*DSQRT(TWO*THREE*AS*(AS+ONE)*(AS-A-ONE)*(AS-A)/
     :((C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE)))
      SI=SI*DSQRT((AS-C-ONE)*(AS-C)*(AS-B+ONE)*(AS-B+TWO)/
     :((B-THREE)*(B-TWO)*(B-ONE)*B*(B+ONE)))
      ENDIF
*  2
      ELSEIF(N-J.EQ.4) THEN
        IF(K-M.EQ.4) THEN
C  V                      -2   2
      SI=AKA*DSQRT((AS-B-THREE)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :((B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)*(B+TWO+THREE)))
      SI=SI*DSQRT((AS-C+ONE)*(AS-C+TWO)*(AS-C+THREE)*(AS-C+FOUR)/
     :((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.4) THEN
C  1                       2   2
      SI=AKA*DSQRT((AS-A+FOUR)*(AS-A+THREE)*(AS-A+TWO)*(AS-A+ONE)/
     :((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)))
      SI=SI*DSQRT((AS+THREE+TWO)*(AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)))
        ELSEIF(K-M.EQ.2) THEN
C  3                      -1   2
      SI=-AKA*DSQRT((AS-A+ONE)*(AS+TWO)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :((B+TWO+THREE)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)))
      SI=SI*TWO*DSQRT((AS-C+THREE)*(AS-C+TWO)*(AS-C+ONE)/
     :((C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.2) THEN
C  2                       1   2
      SI=-AKA*DSQRT((AS-B)*(AS-C+ONE)*(AS-A+THREE)*(AS-A+TWO)*
     :(AS-A+ONE)/
     :((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)))
      SI=SI*TWO*DSQRT((AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C))
        ELSEIF(K-M.EQ.0) THEN
C  5                        0   2
      SI=AKA*DSQRT(THREE*TWO*(AS-B)*(AS-B-ONE)*(AS-C+TWO)*(AS-C+ONE)/
     :((B+THREE+TWO)*(B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)))
      SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :((C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
      ENDIF
      ELSEIF(J-N.EQ.2) THEN
* -1
        IF(K-M.EQ.4) THEN
C  II   P(12)              -2  -1
      SI=AKA*TWO*DSQRT((AS-ONE)*AS*(AS+ONE)/
     :((B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
      SI=SI*DSQRT((AS-A-TWO)*(AS-A-ONE)*(AS-A)*(AS-B)*(AS-C+ONE)/
     :((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.4) THEN
C  3   P(12)                2  -1
      SI=-AKA*DSQRT((AS-A+ONE)*(AS+TWO)*(AS-C-TWO)*(AS-C-ONE)*(AS-C)/
     :((C+TWO+THREE)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)))
      SI=SI*TWO*DSQRT((AS-B+THREE)*(AS-B+TWO)*(AS-B+ONE)/
     :((B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
        ELSEIF(K-M.EQ.2) THEN
C  VI                       -1  -1
      SI=AKA*((A+B)*(A-B+TWO)-(C-TWO)*(C-B+TWO))/
     :DSQRT((B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO))
      SI=SI*DSQRT(AS*(AS+ONE)*(AS-A-ONE)*(AS-A)/
     :((C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.2) THEN
C  VIII P(12)              1  -1
      SI=AKA*((A+C+FOUR)*(A-C-TWO)-(B-TWO)*(B+C+FOUR))/
     :DSQRT(C*(C+ONE)*(C+TWO)*(C+THREE)*(C+FOUR))
      SI=SI*DSQRT((AS-C-ONE)*(AS-C)*(AS-B+ONE)*(AS-B+TWO)/
     :((B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
        ELSEIF(K-M.EQ.0) THEN
C  VII  P(12)              0  -1
      SI=AKA*HALF*((A+C+TWO)*(A-C)-B*B+FOUR)/
     :DSQRT((C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE))
      SI=SI*DSQRT(THREE*TWO*(AS+ONE)*(AS-A)*(AS-C)*(AS-B+ONE)/
     :((B-TWO)*(B-ONE)*B*(B+ONE)*(B+TWO)))
      ENDIF
      ELSEIF(N-J.EQ.2) THEN
*  1
        IF(K-M.EQ.4) THEN
C  IV                     -2   1
      SI=AKA*TWO*DSQRT((AS+ONE)*(AS-A)*(AS-B-TWO)*(AS-B-ONE)*(AS-B)/
     :(B*(B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR)))
      SI=SI*DSQRT((AS-C+ONE)*(AS-C+TWO)*(AS-C+THREE)/
     :((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.4) THEN
C  2 P(12)                 2   1
      SI=-AKA*DSQRT((AS-C)*(AS-B+ONE)*(AS-A+THREE)*(AS-A+TWO)*
     :(AS-A+ONE)/
     :((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)))
      SI=SI*TWO*DSQRT((AS+FOUR)*(AS+THREE)*(AS+TWO)/
     :((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B))
        ELSEIF(K-M.EQ.2) THEN
C  VIII                   -1   1
      SI=AKA*((A+B+FOUR)*(A-B-TWO)-(C-TWO)*(B+C+FOUR))/
     :DSQRT(B*(B+ONE)*(B+TWO)*(B+THREE)*(B+FOUR))
      SI=SI*DSQRT((AS-B-ONE)*(AS-B)*(AS-C+ONE)*(AS-C+TWO)/
     :((C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.2) THEN
C  4                       1   1
      SI=AKA*(THREE*(AS-B)*(AS-C)-(AS-A)*(AS+FOUR))/
     :DSQRT((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B)
      SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C))
        ELSEIF(K-M.EQ.0) THEN
C  6 P(12)                 0   1
      SI=-AKA*((AS-B-ONE)*(AS-C)-(AS-A)*(AS+THREE))/
     :DSQRT((B+FOUR)*(B+THREE)*(B+TWO)*(B+ONE)*B)
      SI=SI*DSQRT(THREE*TWO*(AS-B)*(AS-C+ONE)*(AS-A+ONE)*(AS+TWO)/
     :((C+THREE)*(C+TWO)*(C+ONE)*C*(C-ONE)))
      ENDIF
      ELSEIF(N-J.EQ.0) THEN
* 0
        IF(K-M.EQ.4) THEN
C  III                     -2   0
      SI=AKA*DSQRT(THREE*TWO*AS*(AS+ONE)*(AS-A-ONE)*(AS-A)/
     :((B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)))
      SI=SI*DSQRT((AS-B-ONE)*(AS-B)*(AS-C+ONE)*(AS-C+TWO)/
     :((C-THREE)*(C-TWO)*(C-ONE)*C*(C+ONE)))
        ELSEIF(M-K.EQ.4) THEN
C  5                        2   0
      SI=AKA*DSQRT(THREE*TWO*(AS-C)*(AS-C-ONE)*(AS-B+TWO)*(AS-B+ONE)/
     :((C+THREE+TWO)*(C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)))
      SI=SI*DSQRT((AS-A+TWO)*(AS-A+ONE)*(AS+THREE)*(AS+TWO)/
     :((B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(K-M.EQ.2) THEN
C  VII                     -1   0
      SI=AKA*HALF*((A+B+TWO)*(A-B)-C*C+FOUR)/
     :DSQRT((B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE))
      SI=SI*DSQRT(THREE*TWO*(AS+ONE)*(AS-A)*(AS-B)*(AS-C+ONE)/
     :((C-TWO)*(C-ONE)*C*(C+ONE)*(C+TWO)))
        ELSEIF(M-K.EQ.2) THEN
C  6                        1   0
      SI=-AKA*((AS-C-ONE)*(AS-B)-(AS-A)*(AS+THREE))/
     :DSQRT((C+FOUR)*(C+THREE)*(C+TWO)*(C+ONE)*C)
      SI=SI*DSQRT(THREE*TWO*(AS-C)*(AS-B+ONE)*(AS-A+ONE)*(AS+TWO)/
     :((B+THREE)*(B+TWO)*(B+ONE)*B*(B-ONE)))
        ELSEIF(K-M.EQ.0) THEN
C  IX                       0   0
      X1=(AS-B)*(AS-B-ONE)*(AS-C)*(AS-C-ONE)
      X2=FOUR*(AS-B)*(AS-C)*(AS-A)*(AS+TWO)
      X3=(AS-A)*(AS-A-ONE)*(AS+THREE)*(AS+TWO)
      SI=AKA*(X1-X2+X3)/
     :DSQRT((B-ONE)*B*(B+ONE)*(B+TWO)*(B+THREE)*
     :(C-ONE)*C*(C+ONE)*(C+TWO)*(C+THREE))
      ENDIF
      ENDIF
      RETURN
      END


MODULE Euler_CharacteristicDecompositionModule_NonRelativistic_IDEAL

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    Half, &
    One
  USE GeometryFieldsModule, ONLY: &
    nGF, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33
  USE FluidFieldsModule, ONLY: &
    nCF, &
    iCF_D, &
    iCF_S1, &
    iCF_S2, &
    iCF_S3, &
    iCF_E, &
    iCF_Ne
  USE Euler_UtilitiesModule_NonRelativistic, ONLY: &
    ComputePrimitive_Euler_NonRelativistic
  USE EquationOfStateModule, ONLY: &
    ComputePressureFromPrimitive, &
    ComputeSoundSpeedFromPrimitive
  USE TimersModule_Euler, ONLY: &
    TimersStart_Euler, &
    TimersStop_Euler, &
    Timer_Euler_SL_CharDecomp

  IMPLICIT NONE
  PRIVATE

  LOGICAL, PARAMETER :: Debug = .FALSE.

  PUBLIC :: ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL

CONTAINS

  SUBROUTINE ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL &
    ( iDim, G, U, R, invR )

    INTEGER,  INTENT(in)  :: iDim
    REAL(DP), INTENT(in)  :: G(nGF)
    REAL(DP), INTENT(in)  :: U(nCF)
    REAL(DP), INTENT(out) :: R(nCF,nCF)
    REAL(DP), INTENT(out) :: invR(nCF,nCF)

    INTEGER :: i
    REAL(DP), DIMENSION(1) :: D, V1, V2, V3, Gmdd11, Gmdd22, Gmdd33, Vu1, Vu2, Vu3, E, Ne, P, Cs
    REAL(DP), DIMENSION(1) :: Q, K, H, J, Mu1, Mu2, Mu3, Vd1, Vd2, Vd3

    CALL TimersStart_Euler( Timer_Euler_SL_CharDecomp )

    CALL ComputePrimitive_Euler_NonRelativistic &
           ( [ U(iCF_D ) ], [ U(iCF_S1) ], [ U(iCF_S2) ], &
             [ U(iCF_S3) ], [ U(iCF_E ) ], [ U(iCF_Ne) ], &
             D, V1, V2, V3, E, Ne, &
             [ G(iGF_Gm_dd_11) ], &
             [ G(iGF_Gm_dd_22) ], &
             [ G(iGF_Gm_dd_33) ] )

    CALL ComputePressureFromPrimitive &
           ( D, E, Ne, P )

    CALL ComputeSoundSpeedFromPrimitive &
           ( D, E, Ne, Cs )

    Gmdd11 = G(iGF_Gm_dd_11)
    Gmdd22 = G(iGF_Gm_dd_22)
    Gmdd33 = G(iGF_Gm_dd_33)

    Vu1 = V1
    Vu2 = V2
    Vu3 = V3

    Vd1 = Gmdd11 * Vu1
    Vd2 = Gmdd22 * Vu2
    Vd3 = Gmdd33 * Vu3

    Q = P / ( E * Cs)
    K = Half * (Vu1 * Vd1 + Vu2 * Vd2 + Vu3 * Vd3)
    H = Q * K / Cs
    J = ( E / P ) * Cs**2 + K
    Mu1 = Vu1 / Cs
    Mu2 = Vu2 / Cs
    Mu3 = Vu3 / Cs

    SELECT CASE( iDim )

      CASE( 1 )

        R(:,1) = [  One, Vd1 - Cs * SQRT( Gmdd11 ),     Vd2,   Vd3, J - Cs * SQRT( Gmdd11 ) * Vu1, Zero ]
        R(:,2) = [  One,                       Vd1,     Vd2,   Vd3,                             K, Zero ]
        R(:,3) = [  One, Vd1 + Cs * SQRT( Gmdd11 ),     Vd2,   Vd3, J + Cs * SQRT( Gmdd11 ) * Vu1, Zero ]
        R(:,4) = [ Zero,                      Zero,   - One,  Zero,                       -   Vu2, Zero ]
        R(:,5) = [ Zero,                      Zero,    Zero,   One,                           Vu3, Zero ]
        R(:,6) = [ Zero,                      Zero,    Zero,  Zero,                          Zero,  One ]

        invR(:,1) &
          = [ Half * ( H + SQRT( Gmdd11 ) * Mu1 ), &
              One - H, &
              Half * ( H - SQRT( Gmdd11 ) * Mu1 ), &
              Vd2, - Vd3, Zero ]

        invR(:,2) &
          = [ - Half * ( Q * Mu1 + One / ( SQRT( Gmdd11 ) * Cs ) ), &
                         Q * Mu1, &
              - Half * ( Q * Mu1 - One / ( SQRT( Gmdd11 ) * Cs ) ), &
              Zero, Zero, Zero ]

        invR(:,3) &
          = [ - Half * Q * Mu2, &
                       Q * Mu2, &
              - Half * Q * Mu2, &
              - One, Zero, Zero ]

        invR(:,4) &
          = [ - Half * Q * Mu3, &
                       Q * Mu3, &
              - Half * Q * Mu3, &
              Zero, One, Zero ]

        invR(:,5) &
          = [ Half * Q / Cs, &
                   - Q / Cs, &
              Half * Q / Cs, &
              Zero, Zero, Zero ]

        invR(:,6) &
          = [ Zero, Zero, Zero, Zero, Zero, One ]

        IF( Debug )THEN

          WRITE(*,*)
          WRITE(*,'(A4,A)') '', 'invR * R (X1):'
          WRITE(*,*)
          DO i = 1, 6
            WRITE(*,'(A4,6ES16.7E2)') '', MATMUL( invR(i,:), R(:,:) )
          END DO

        END IF

      CASE( 2 )

        R(:,1) = [  One,    Vd1, Vd2 - Cs * SQRT( Gmdd22 ),    Vd3, J - Cs * SQRT( Gmdd22 ) * Vu2, Zero ]
        R(:,2) = [  One,    Vd1,                       Vd2,    Vd3,                             K, Zero ]
        R(:,3) = [  One,    Vd1, Vd2 + Cs * SQRT( Gmdd22 ),    Vd3, J + Cs * SQRT( Gmdd22 ) * Vu2, Zero ]
        R(:,4) = [ Zero,  - One,                      Zero,   Zero,                         - Vu1, Zero ]
        R(:,5) = [ Zero,   Zero,                      Zero,    One,                           Vu3, Zero ]
        R(:,6) = [ Zero,   Zero,                      Zero,   Zero,                          Zero,  One ]

        invR(:,1) &
          = [ Half * ( H + SQRT( Gmdd22 ) * Mu2 ), &
              One - H, &
              Half * ( H - SQRT( Gmdd22 ) * Mu2 ), &
                Vd1, - Vd3, Zero ]

        invR(:,2) &
          = [ - Half * Q * Mu1, &
                       Q * Mu1, &
              - Half * Q * Mu1, &
              - One, Zero, Zero ]

        invR(:,3) &
          = [ - Half * ( Q * Mu2 + One / ( SQRT( Gmdd22 ) * Cs ) ), &
                         Q * Mu2, &
              - Half * ( Q * Mu2 - One / ( SQRT( Gmdd22 ) * Cs ) ), &
              Zero, Zero, Zero ]

        invR(:,4) &
          = [ - Half * Q * Mu3, &
                       Q * Mu3, &
              - Half * Q * Mu3, &
              Zero, One, Zero ]

        invR(:,5) &
          = [ Half * Q / Cs, &
                   - Q / Cs, &
              Half * Q / Cs, &
              Zero, Zero, Zero ]

        invR(:,6) &
          = [ Zero, Zero, Zero, Zero, Zero, One ]

        IF( Debug )THEN

          WRITE(*,*)
          WRITE(*,'(A4,A)') '', 'invR * R (X2):'
          WRITE(*,*)
          DO i = 1, 6
            WRITE(*,'(A4,6ES16.7E2)') '', MATMUL( invR(i,:), R(:,:) )
          END DO

        END IF

      CASE( 3 )

        R(:,1) = [  One,   Vd1,     Vd2,   Vd3 - Cs * SQRT( Gmdd33 ), J - Cs * SQRT( Gmdd33 ) * Vu3, Zero ]
        R(:,2) = [  One,   Vd1,     Vd2,                         Vd3,                             K, Zero ]
        R(:,3) = [  One,   Vd1,     Vd2,   Vd3 + Cs * SQRT( Gmdd33 ), J + Cs * SQRT( Gmdd33 ) * Vu3, Zero ]
        R(:,4) = [ Zero, - One,    Zero,                        Zero,                         - Vu1, Zero ]
        R(:,5) = [ Zero,  Zero,     One,                        Zero,                           Vu2, Zero ]
        R(:,6) = [ Zero,  Zero,    Zero,                        Zero,                          Zero,  One ]

        invR(:,1) &
          = [ Half * ( H + SQRT( Gmdd33 ) * Mu3 ), &
              One - H, &
              Half * ( H - SQRT( Gmdd33 ) * Mu3 ), &
              Vd1, - Vd2, Zero ]

        invR(:,2) &
          = [ - Half * Q * Mu1, &
                       Q * Mu1, &
              - Half * Q * Mu1, &
              - One, Zero, Zero ]

        invR(:,3) &
          = [ - Half * Q * Mu2, &
                       Q * Mu2, &
              - Half * Q * Mu2, &
                Zero, One, Zero ]

        invR(:,4) &
          = [ - Half * ( Q * Mu3 + One / ( SQRT( Gmdd33 ) * Cs  ) ), &
                         Q * Mu3, &
              - Half * ( Q * Mu3 + One / ( SQRT( Gmdd33 ) * Cs  ) ), &
               Zero, Zero, Zero ]

        invR(:,5) &
          = [ Half * Q / Cs, &
                   - Q / Cs, &
              Half * Q / Cs, &
              Zero, Zero, Zero ]

        invR(:,6) &
          = [ Zero, Zero, Zero, Zero, Zero, One ]

        IF( Debug )THEN

          WRITE(*,*)
          WRITE(*,'(A4,A)') '', 'invR * R (X3):'
          WRITE(*,*)
          DO i = 1, 6
            WRITE(*,'(A4,6ES16.7E2)') '', MATMUL( invR(i,:), R(:,:) )
          END DO

        END IF

    END SELECT

    CALL TimersStop_Euler( Timer_Euler_SL_CharDecomp )

  END SUBROUTINE ComputeCharacteristicDecomposition_Euler_NonRelativistic_IDEAL

END MODULE Euler_CharacteristicDecompositionModule_NonRelativistic_IDEAL


      SUBROUTINE HSFLX (S,RH,ZPX,HPK,HPS,HPC)
C     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
      COMPLEX FJ,FJK,EKR1,EKR2,T1,T2,CONS,HPS,HPC,HPK
      DIMENSION FJX(2), FJKX(2)
      EQUIVALENCE (FJ,FJX), (FJK,FJKX)
      DATA TP/6.283185308/,FJX/0.,1./,FJKX/0.,-6.283185308/
      DATA PI8/25.13274123/
      IF (RH.LT.1.E-10) GO TO 6
      IF (ZPX.LT.0.) GO TO 1
      ZP=ZPX
      HSS=1.
      GO TO 2
1     ZP=-ZPX
      HSS=-1.
2     DH=.5*S
      Z1=ZP+DH
      Z2=ZP-DH
      IF (Z2.LT.1.E-7) GO TO 3
      RHZ=RH/Z2
      GO TO 4
3     RHZ=1.
4     DK=TP*DH
      CDK=COS(DK)
      SDK=SIN(DK)
      CALL HFK (-DK,DK,RH*TP,ZP*TP,HKR,HKI)
      HPK=CMPLX(HKR,HKI)
      IF (RHZ.LT.1.E-3) GO TO 5
      RH2=RH*RH
      R1=SQRT(RH2+Z1*Z1)
      R2=SQRT(RH2+Z2*Z2)
      EKR1=CEXP(FJK*R1)
      EKR2=CEXP(FJK*R2)
      T1=Z1*EKR1/R1
      T2=Z2*EKR2/R2
      HPS=(CDK*(EKR2-EKR1)-FJ*SDK*(T2+T1))*HSS
      HPC=-SDK*(EKR2+EKR1)-FJ*CDK*(T2-T1)
      CONS=-FJ/(2.*TP*RH)
      HPS=CONS*HPS
      HPC=CONS*HPC
      RETURN
5     EKR1=CMPLX(CDK,SDK)/(Z2*Z2)
      EKR2=CMPLX(CDK,-SDK)/(Z1*Z1)
      T1=TP*(1./Z1-1./Z2)
      T2=CEXP(FJK*ZP)*RH/PI8
      HPS=T2*(T1+(EKR1+EKR2)*SDK)*HSS
      HPC=T2*(-FJ*T1+(EKR1-EKR2)*CDK)
      RETURN
6     HPS=(0.,0.)
      HPC=(0.,0.)
      HPK=(0.,0.)
      RETURN
      END


      SUBROUTINE coil_curve (nu, uc, us, nv, vc, vs, la, lb, lc,
     1   ls, nf, ns, mnum, nnum, rmn, zmn, nfil, s, alf, bet,
     2   deln, delt, u, v, r, c, x, y, z, ierr)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE stel_constants
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y  A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(out) :: ierr
      INTEGER, INTENT(in)  :: nu, nv, nf, ns, nfil
      REAL(rprec), INTENT(in)  :: s, alf, bet, deln, delt
      REAL(rprec), INTENT(out) :: r
      REAL(rprec), INTENT(out) :: u, v
      REAL(rprec), DIMENSION(0:*), INTENT(inout) :: uc, us
      REAL(rprec), DIMENSION(0:*), INTENT(inout) :: vc, vs
      INTEGER, DIMENSION(*), INTENT(in) :: nnum, mnum
      REAL(rprec), DIMENSION(*), INTENT(in) :: rmn, zmn
      REAL(rprec), DIMENSION(2,3,5), INTENT(out) :: x, y, z
      REAL(rprec), DIMENSION(2), INTENT(out) :: c
      LOGICAL, INTENT(in) :: la, lb, lc, ls
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: i, k, n, np, mk, nk, ifail
      REAL(rprec), DIMENSION(2) :: x0, x1, x2
      REAL(rprec), DIMENSION(2) :: y0, y1, y2
      REAL(rprec), DIMENSION(2) :: tcx, tcy, tcz
      REAL(rprec), DIMENSION(2) :: tsx, tsy, tsz
      REAL(rprec), DIMENSION(2) :: xu, xv, yu, yv
      REAL(rprec), DIMENSION(2) :: nx, ny, nz, nr, nphi, dn, d1
      REAL(rprec), DIMENSION(2) :: ph0,  ph1,  ph2, phv
      REAL(rprec), DIMENSION(4) :: fu, fv
      REAL(rprec) :: s0, s1, dph
      REAL(rprec) :: ck, sk
      REAL(rprec) :: r0, r1, r2
      REAL(rprec) :: z0, z1, z2
      REAL(rprec) :: u0,  u1,  u2
      REAL(rprec) :: v0,  v1,  v2
      REAL(rprec) :: ru, rv, zu, zv
      REAL(rprec) :: sinph0, cosph0
!-----------------------------------------------

      dph = twopi/nf
      s0 = twopi*s
      s1 = twopi

!     compute toroidal variable v and derivatives wrt s
      IF (ls) THEN

         ! b-spline series representation
         IF (lc) THEN
            v0 = 0
         ELSE
            v0 = vc(0)
         END IF
         v1 = 0
         v2 = 0
         ! coefficients
         IF (nv .lt. 7) THEN
            ierr = 1
         ELSE
            ! breakpoint boundary conditions
            DO k = 1, 4
               vs(k) = zero
               vs(nv + k) = one
            END DO
            ! control point boundary conditions
!           IF (lc) THEN
!              vc(nv) = vc(1)
!              vc(nv-1) = 2.0_dp*vc(1) - vc(2)
!              vc(nv-2) = 2.0_dp*vc(1) - vc(3)
!           END IF
            CALL speval (nv, vs, vc, s, fv, ifail)
            v0 = v0 + fv(1)
            v1 = fv(2)
            v2 = fv(3)
         END IF

      ELSE

         ! fourier series representation
         v0 = 0
         v1 = 0
         v2 = 0
         DO k = 0,nv
            ck = COS(k*s0)
            sk = SIN(k*s0)
            v0 = v0 +  vc(k)*ck + vs(k)*sk
            v1 = v1 + (vs(k)*ck - vc(k)*sk)*k
            v2 = v2 + (vs(k)*sk + vc(k)*ck)*k**2
         END DO
         v1 = s1*v1
         v2 = -s1**2*v2

      END IF           ! IF (ls)

      IF (lb .and. (.not. lc)) THEN
!     lb = T => helical or wavy_pf
         v0 = v0 + s
         v1 = v1 + 1
      END IF

!     compute poloidal variable u and derivatives wrt s
      IF (ls) THEN

         ! b-spline series representation
         u0 = 0
         u1 = 0
         u2 = 0
         ! coefficients
         IF (nu .lt. 7) THEN
            ierr = 1
         ELSE
            ! breakpoint boundary conditions
            DO k = 1, 4
               us(k) = zero
               us(nu + k) = one
            END DO
            ! control point boundary conditions
!           IF (lc) THEN
!              uc(nu) = one + uc(1)
!              uc(nu-1) = uc(nu) - uc(2) + uc(1)
!              uc(nu-2) = uc(nu) - uc(3) + uc(1)
!           END IF
            CALL speval (nu, us, uc, s, fu, ifail)
            u0 = fu(1)
            u1 = fu(2)
            u2 = fu(3)
         END IF

      ELSE

         ! fourier series representation
         u0 = 0
         u1 = 0
         u2 = 0
         DO k = 0,nu
            ck = COS(k*s0)
            sk = SIN(k*s0)
            u0 = u0 +  uc(k)*ck + us(k)*sk
            u1 = u1 + (us(k)*ck - uc(k)*sk)*k
            u2 = u2 + (us(k)*sk + uc(k)*ck)*k**2
         END DO

         u1 = s1*u1
         u2 = -s1**2*u2

      END IF           ! IF (ls)

      IF (la .and. (.not. lc)) THEN
!        la = T => modular
         u0 = u0 + s
         u1 = u1 + 1
      END IF

!     compute R, Z and derivatives wrt s

      r0 = 0
      r1 = 0
      r2 = 0
      z0 = 0
      z1 = 0
      z2 = 0
      ru = 0
      rv = 0
      zu = 0
      zv = 0
      DO k = 1, ns
         mk = mnum(k)
         nk = nnum(k)
         ck = COS(twopi*(mk*u0 + nk*v0))    !!Half time used by these 2 lines on PC
         sk = SIN(twopi*(mk*u0 + nk*v0))
!     R ...
         r0 = r0 + rmn(k)*ck
         r1 = r1 - rmn(k)*(twopi*(mk*u1 + nk*v1))*sk
         r2 = r2 - rmn(k)*((twopi*(mk*u2 + nk*v2))*sk
     1      + (twopi*(mk*u1 + nk*v1))**2*ck)
         ru = ru - rmn(k)*mk*sk*twopi
         rv = rv - rmn(k)*nk*sk*twopi
!     Z ...
         z0 = z0 + zmn(k)*sk
         z1 = z1 + zmn(k)*(twopi*(mk*u1 + nk*v1))*ck
         z2 = z2 + zmn(k)*((twopi*(mk*u2 + nk*v2))*ck
     1      - (twopi*(mk*u1 + nk*v1))**2*sk)
         zu = zu + zmn(k)*mk*ck*twopi
         zv = zv + zmn(k)*nk*ck*twopi
      END DO

!     derivatives of toroidal angle wrt s
      ph1(1) =  twopi*v1/nf
      ph1(2) = -twopi*v1/nf
      ph2(1) =  twopi*v2/nf
      ph2(2) = -twopi*v2/nf
      phv(1) =  twopi/nf
      phv(2) = -twopi/nf

!     field period invariance
      DO np = 1,nf

!        toroidal angle in field period np
         ph0(1) =  twopi*v0/nf + (np - 1)*dph
         ph0(2) = -twopi*v0/nf + (np - 1)*dph

!        stellarator symmetry
         DO i = 1,2
!        X and derivatives wrt s
         sinph0 = SIN(ph0(i))
         cosph0 = COS(ph0(i))
         x0(i) = r0*cosph0
         x1(i) = r1*cosph0 - r0*ph1(i)*sinph0
         x2(i) = r2*cosph0 - r1*ph1(i)*sinph0
     1         - (r0*ph1(i)**2*cosph0
     2         + (r0*ph2(i) + r1*ph1(i))*sinph0)

!        X derivatives wrt u, v

         xu(i) = ru*cosph0
         xv(i) = rv*cosph0 - r0*sinph0*phv(i)

!        Y and derivatives wrt s

         y0(i) = r0*sinph0
         y1(i) = r1*sinph0 + r0*ph1(i)*cosph0
         y2(i) = r2*sinph0 + r1*ph1(i)*cosph0
     1         + (-r0*ph1(i)**2*sinph0
     2         + (r0*ph2(i) + r1*ph1(i))*cosph0)

!        Y derivatives wrt u, v

         yu(i) = ru*sinph0
         yv(i) = rv*sinph0 + r0*cosph0*phv(i)

!        compute |dr/ds| = dl/ds

         d1(i) = SQRT (x1(i)*x1(i) + y1(i)*y1(i) + z1*z1)

!        END loop for stellarator symmetry
         END DO

!        Tangent vector (to curve) tcx=dx/ds, tcy=dy/ds, tcz=dz/ds

         tcx(1) =  x1(1)/d1(1)
         tcy(1) =  y1(1)/d1(1)
         tcz(1) =  z1/d1(1)
!        stellarator symmetry
         tcx(2) =  x1(2)/d1(2)
         tcy(2) =  y1(2)/d1(2)
         tcz(2) = -z1/d1(2)

!        components of surface normal vector (cylindrical) nr, nphi, nz

         nr(1) =  r0*zu
         nphi(1) =  ru*zv - rv*zu
         nz(1) = -r0*ru
         dn(1) =  SQRT (nr(1)*nr(1) + nphi(1)*nphi(1) + nz(1)*nz(1))
         nr(1) =  nr(1)/dn(1)
         nphi(1) = nphi(1)/dn(1)
         nz(1) =  nz(1)/dn(1)
!        stellarator symmetry
         nr(2) = -r0*zu
         nphi(2) = -ru*zv + rv*zu
         nz(2) = -r0*ru
         dn(2) =  SQRT (nr(2)*nr(2) + nphi(2)*nphi(2) + nz(2)*nz(2))
         nr(2) =  nr(2)/dn(2)
         nphi(2) = nphi(2)/dn(2)
         nz(2) =  nz(2)/dn(2)

!        components of surface normal vector (cartesian) nx, ny, nz

         nx(1) =  yu(1)*zv - zu*yv(1)
         ny(1) =  zu*xv(1) - zv*xu(1)
         nz(1) =  xu(1)*yv(1) - xv(1)*yu(1)
         dn(1) =  SQRT (nx(1)*nx(1) + ny(1)*ny(1) + nz(1)*nz(1))
         nx(1) =  nx(1)/dn(1)
         ny(1) =  ny(1)/dn(1)
         nz(1) =  nz(1)/dn(1)
!        stellarator symmetry
         nx(2) = -yu(2)*zv + zu*yv(2)
         ny(2) = -zu*xv(2) + zv*xu(2)
         nz(2) =  xu(2)*yv(2) - xv(2)*yu(2)
         dn(2) =  SQRT (nx(2)*nx(2) + ny(2)*ny(2) + nz(2)*nz(2))
         nx(2) =  nx(2)/dn(2)
         ny(2) =  ny(2)/dn(2)
         nz(2) =  nz(2)/dn(2)

!        TANgent vector (to surface) tsx, tsy, tsz

         tsx(1) = ny(1)*tcz(1) - tcy(1)*nz(1)
         tsy(1) = nz(1)*tcx(1) - tcz(1)*nx(1)
         tsz(1) = nx(1)*tcy(1) - tcx(1)*ny(1)
         dn(1) = SQRT (tsx(1)*tsx(1) + tsy(1)*tsy(1) + tsz(1)*tsz(1))
         tsx(1) = tsx(1)/dn(1)
         tsy(1) = tsy(1)/dn(1)
         tsz(1) = tsz(1)/dn(1)
!        stellarator symmetry
         tsx(2) = ny(2)*tcz(2) - tcy(2)*nz(2)
         tsy(2) = nz(2)*tcx(2) - tcz(2)*nx(2)
         tsz(2) = nx(2)*tcy(2) - tcx(2)*ny(2)
         dn(2) = SQRT (tsx(2)*tsx(2) + tsy(2)*tsy(2) + tsz(2)*tsz(2))
         tsx(2) = tsx(2)/dn(2)
         tsy(2) = tsy(2)/dn(2)
         tsz(2) = tsz(2)/dn(2)

!        RETURN curvature c = |dr/ds X d2r/ds2|/|dr/ds|^3

         c(1) = SQRT ((y1(1)*z2 - y2(1)*z1)**2
     1        + (z1*x2(1) - z2*x1(1))**2
     2        + (x1(1)*y2(1) - x2(1)*y1(1))**2)/d1(1)**3
!        stellarator symmetry
         c(2) = SQRT ((-y1(2)*z2 + y2(2)*z1)**2
     1        + (-z1*x2(2) + z2*x1(2))**2
     2        + (x1(2)*y2(2) - x2(2)*y1(2))**2)/d1(2)**3

!        RETURN multifilament representation for x, y, z
!        filament 1
         n = 1
         x(1,np,n) =  x0(1)
         y(1,np,n) =  y0(1)
         z(1,np,n) =  z0
!        stellarator symmetry
         x(2,np,n) =  x0(2)
         y(2,np,n) =  y0(2)
         z(2,np,n) = -z0
         IF (nfil .lt. 4) THEN
!           Three filament model
!           filament 2
            n = 2
            x(1,np,n) =  x0(1) + deln*(alf*nx(1) + bet*tsx(1))
            y(1,np,n) =  y0(1) + deln*(alf*ny(1) + bet*tsy(1))
            z(1,np,n) =  z0    + deln*(alf*nz(1) + bet*tsz(1))
!           stellarator symmetry
            x(2,np,n) =  x0(2) + deln*(alf*nx(2) + bet*tsx(2))
            y(2,np,n) =  y0(2) + deln*(alf*ny(2) + bet*tsy(2))
            z(2,np,n) = -z0    + deln*(alf*nz(2) + bet*tsz(2))
!           filament 3
            n = 3
            x(1,np,n) =  x0(1) - deln*(alf*nx(1) + bet*tsx(1))
            y(1,np,n) =  y0(1) - deln*(alf*ny(1) + bet*tsy(1))
            z(1,np,n) =  z0    - deln*(alf*nz(1) + bet*tsz(1))
!           stellarator symmetry
            x(2,np,n) =  x0(2) - deln*(alf*nx(2) + bet*tsx(2))
            y(2,np,n) =  y0(2) - deln*(alf*ny(2) + bet*tsy(2))
            z(2,np,n) = -z0    - deln*(alf*nz(2) + bet*tsz(2))
         ELSE
!           Four filament model (no current in central filament 1)
!           filament 2
            n = 2
            x(1,np,n) =  x0(1) + deln*nx(1) + delt*tsx(1)
            y(1,np,n) =  y0(1) + deln*ny(1) + delt*tsy(1)
            z(1,np,n) =  z0    + deln*nz(1) + delt*tsz(1)
!           stellarator symmetry
            x(2,np,n) =  x0(2) + deln*nx(2) + delt*tsx(2)
            y(2,np,n) =  y0(2) + deln*ny(2) + delt*tsy(2)
            z(2,np,n) = -z0    + deln*nz(2) + delt*tsz(2)
!           filament 3
            n = 3
            x(1,np,n) =  x0(1) - deln*nx(1) + delt*tsx(1)
            y(1,np,n) =  y0(1) - deln*ny(1) + delt*tsy(1)
            z(1,np,n) =  z0    - deln*nz(1) + delt*tsz(1)
!           stellarator symmetry
            x(2,np,n) =  x0(2) - deln*nx(2) + delt*tsx(2)
            y(2,np,n) =  y0(2) - deln*ny(2) + delt*tsy(2)
            z(2,np,n) = -z0    - deln*nz(2) + delt*tsz(2)
!           filament 4
            n = 4
            x(1,np,n) =  x0(1) - deln*nx(1) - delt*tsx(1)
            y(1,np,n) =  y0(1) - deln*ny(1) - delt*tsy(1)
            z(1,np,n) =  z0    - deln*nz(1) - delt*tsz(1)
!           stellarator symmetry
            x(2,np,n) =  x0(2) - deln*nx(2) - delt*tsx(2)
            y(2,np,n) =  y0(2) - deln*ny(2) - delt*tsy(2)
            z(2,np,n) = -z0    - deln*nz(2) - delt*tsz(2)
!           filament 5
            n = 5
            x(1,np,n) =  x0(1) + deln*nx(1) - delt*tsx(1)
            y(1,np,n) =  y0(1) + deln*ny(1) - delt*tsy(1)
            z(1,np,n) =  z0    + deln*nz(1) - delt*tsz(1)
!           stellarator symmetry
            x(2,np,n) =  x0(2) + deln*nx(2) - delt*tsx(2)
            y(2,np,n) =  y0(2) + deln*ny(2) - delt*tsy(2)
            z(2,np,n) = -z0    + deln*nz(2) - delt*tsz(2)
         END IF      ! number of filaments (nfil)

!     END loop for field period invariance
      END DO

!     RETURN u, v, r
      u = u0
      v = v0
      r = r0

      END SUBROUTINE coil_curve


Subroutine CEMAComputeTurbidity

Use GLOBAL
Use SCREENC
Use CEMAVars

! Type declarations
IMPLICIT NONE

Real(8) CellTSSValue
Integer(2) K

    Do JW=1, NWB
        KT = KTWB(JW)
        Do JB=BS(JW),BE(JW)
            IU = CUS(JB)
            ID = DS(JB)
            Do SegNumI = IU, ID
                Do K = KT, KB(SegNumI)
                    !CellTSSValue = C1(K,SegNumI,6)
                    CellTSSValue = C1(K,SegNumI,nturb)      ! cb 2/18/13
                    !C1(K,SegNumI,6) = exp(CoeffA_Turb*log(CellTSSValue) + CoeffB_Turb)
                    !C2(K,SegNumI,6) = exp(CoeffA_Turb*log(CellTSSValue) + CoeffB_Turb)
                    C1(K,SegNumI,nturb) = exp(CoeffA_Turb*log(CellTSSValue) + CoeffB_Turb)       ! cb 2/18/13
                    C2(K,SegNumI,nturb) = exp(CoeffA_Turb*log(CellTSSValue) + CoeffB_Turb)
                End Do !K
            End Do
        End Do
    End Do

Return
End Subroutine


MODULE mod_mdct
IMPLICIT NONE
PRIVATE
PUBLIC :: mdct_initialize, sub_mdct
REAL (KIND = 8):: pi
INTEGER :: indx9(9)
COMPLEX (KIND = 8), SAVE:: omega9(0:8), omega9s(9), sqrt3_2, omega3(0:2), omega3s(3)
REAL (KIND = 8), PARAMETER :: c(0:7) = (/ -0.6000d0, -0.5350d0, -0.3300d0, -0.1850d0, -0.0950d0, -0.0410d0, -0.0142d0, -0.0037d0/)
REAL (KIND = 8), SAVE :: ca(0:7), cs(0:7), window_n(36), window_s(12), window_start(36), window_stop(36)
REAL (KIND = 8), SAVE, ALLOCATABLE :: subbuff(:, :, :)
CONTAINS
!---------------------------------------------------------------------------------------------
SUBROUTINE mdct_initialize()
IMPLICIT NONE
INTEGER :: i
pi = 4.0d0 * ATAN(1.0d0)
subbuff = 0.0d0
CALL fft9_initialize()
CALL fft3_initialize()
! ISO Table B.9 coefficients for aliasing reduction:
DO i = 0, 7
 cs(i) =  SQRT( 1.0d0    / ( 1.0d0 + c(i)**2 ) )
 ca(i) = -SQRT( c(i)**2  / ( 1.0d0 + c(i)**2 ) )
END DO
! ISO 2.4.3.4.10.3 Windowing, C.1.5.3.3
! normal window
DO i = 1, 36
 window_n(i) = SIN( REAL(2 * i - 1, KIND = 8) / 72.0d0 * pi)
END DO
! short window
DO i = 1, 12
 window_s(i) = SIN( REAL(2 * i - 1, KIND = 8) / 24.0d0 * pi)
END DO
! start / stop window
DO i = 1, 18
 window_start(i     ) = SIN( REAL(2 *  i       - 1, KIND = 8) / 72.0d0 * pi)
 window_stop (i + 18) = SIN( REAL(2 * (i + 18) - 1, KIND = 8) / 72.0d0 * pi)
END DO
DO i = 1, 6
 window_start(i + 24) = SIN( REAL(2 * (i + 6) - 1, KIND = 8) / 24.0d0 * pi)
 window_stop (i +  6) = SIN( REAL(2 *  i      - 1, KIND = 8) / 24.0d0 * pi)
END DO
window_start(19:24) = 1.0d0
window_start(31:36) = 0.0d0
window_stop ( 1: 6) = 0.0d0
window_stop (13:18) = 1.0d0
RETURN
END SUBROUTINE mdct_initialize
!-------------------------------------------------------------------------------------------------
SUBROUTINE cp_subband(subband, subbuff)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: subband(:, :, :) ! 32 * 36 * nchannel
REAL (KIND = 8), INTENT(OUT) :: subbuff(:, :, :) ! 32 * 54 * nchannel
subbuff = EOSHIFT(subbuff, 36, 0.0d0, 2)
subbuff(:     , 19:54  , :) =  subband(:, :, :)
subbuff(2:32:2, 20:54:2, :) = -subbuff(2:32:2, 20:54:2, :) ! ISO Figure A.4 Layer III decoder diagram
RETURN                                                     !    ~~~~~~~~~~~~ not written in the text but only in Figure
END SUBROUTINE cp_subband
!--------------------------------------------------------------------------------------------------
SUBROUTINE sub_mdct(subband, r_mdct, mblock_type, q_alias)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: subband(:, :, :)
REAL (KIND = 8), INTENT(OUT) :: r_mdct (:, :, :, :)
INTEGER        , INTENT(IN ) :: mblock_type(:)
LOGICAL        , INTENT(IN ) :: q_alias
INTEGER :: igranule, ichannel
LOGICAL, SAVE :: qfirst = .TRUE.
IF (qfirst) THEN
 qfirst = .FALSE.
 ALLOCATE( subbuff(32, 54, SIZE(subband, 3)) )
 subbuff = 0.0d0
 CALL mdct_initialize()
END IF
CALL cp_subband(subband, subbuff)
DO ichannel = 1, SIZE(subband, 3)
 DO igranule = 1, 2
  SELECT CASE (mblock_type(igranule))
   CASE ( 0) ! long block
    CALL sub_mdct_normal(igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL anti_alias(r_mdct(1:32, :, igranule, ichannel))
   CASE (10) ! start block : long -> short
    CALL sub_mdct_start (igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL anti_alias(r_mdct(1:32, :, igranule, ichannel))
   CASE (11) ! start block : long -> mixed
    CALL sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL sub_mdct_start (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL anti_alias(r_mdct(1:32, :, igranule, ichannel))
   CASE (30) ! stop block : short -> long
    CALL sub_mdct_stop  (igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL anti_alias(r_mdct(1:32, :, igranule, ichannel))
   CASE (31) ! stop block : mixed -> long
    CALL sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL sub_mdct_stop  (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL anti_alias(r_mdct(1:32, :, igranule, ichannel))
   CASE (20) ! short block : short mode
    CALL sub_mdct_short(igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
   CASE (21) ! short block : mixed mode
    CALL sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    CALL sub_mdct_short (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
    IF (q_alias) CALL anti_alias(r_mdct(1:2, :, igranule, ichannel))
   CASE DEFAULT
    STOP 'error : SUBROUTINE sub_mdct : block_type error'
  END SELECT
 END DO
END DO
RETURN
END SUBROUTINE sub_mdct
!--------------------------------------------------------------------------------------------------
SUBROUTINE sub_mdct_normal(igranule, n0, n1, subbuff, r_mdct)
IMPLICIT NONE
INTEGER        , INTENT(IN ) :: igranule, n0, n1
REAL (KIND = 8), INTENT(IN ) :: subbuff(:, :)
REAL (KIND = 8), INTENT(OUT) :: r_mdct (:, :)
REAL (KIND = 8)              :: wk(36)
INTEGER :: iband, k
k = 18 * (igranule - 1) + 1
DO iband = n0, n1
 wk = window_n * subbuff(iband, k:k + 35)
 CALL mdct36(wk, r_mdct(iband, :))
END DO
RETURN
END SUBROUTINE sub_mdct_normal
!--------------------------------------------------------------------------------------------------
SUBROUTINE sub_mdct_start(igranule, n0, n1, subbuff, r_mdct)
IMPLICIT NONE
INTEGER        , INTENT(IN ) :: igranule, n0, n1
REAL (KIND = 8), INTENT(IN ) :: subbuff(:, :)
REAL (KIND = 8), INTENT(OUT) :: r_mdct (:, :)
REAL (KIND = 8)              :: wk(36)
INTEGER :: iband, k
k = 18 * (igranule - 1) + 1
DO iband = n0, n1
 wk = window_start * subbuff(iband, k:k + 35)
 CALL mdct36(wk, r_mdct(iband, :))
END DO
RETURN
END SUBROUTINE sub_mdct_start
!--------------------------------------------------------------------------------------------------
SUBROUTINE sub_mdct_stop(igranule, n0, n1, subbuff, r_mdct)
IMPLICIT NONE
INTEGER        , INTENT(IN ) :: igranule, n0, n1
REAL (KIND = 8), INTENT(IN ) :: subbuff(:, :)
REAL (KIND = 8), INTENT(OUT) :: r_mdct (:, :)
REAL (KIND = 8)              :: wk(36)
INTEGER :: iband, k
k = 18 * (igranule - 1) + 1
DO iband = n0, n1
 wk = window_stop * subbuff(iband, k:k + 35)
 CALL mdct36(wk, r_mdct(iband, :))
END DO
RETURN
END SUBROUTINE sub_mdct_stop
!--------------------------------------------------------------------------------------------------
SUBROUTINE sub_mdct_short(igranule, n0, n1, subbuff, r_mdct)
IMPLICIT NONE
INTEGER        , INTENT(IN ) :: igranule, n0, n1
REAL (KIND = 8), INTENT(IN ) :: subbuff(:, :)
REAL (KIND = 8), INTENT(OUT) :: r_mdct (:, :)
REAL (KIND = 8)              :: wk(12)
INTEGER :: iband, k, m, m0, n
m0 = 18 * (igranule - 1) + 1 + 6
DO k = 1, 3
 m = m0 + 6 * (k - 1)
 n =  1 + 6 * (k - 1)
 DO iband = n0, n1
  wk = window_s * subbuff(iband, m:m + 11)
  CALL mdct12(wk, r_mdct(iband, n:n + 5))
 END DO
END DO
RETURN
END SUBROUTINE sub_mdct_short
!--------------------------------------------------------------------------------------------------
SUBROUTINE anti_alias(x) ! C.1.5.3.3 Aliasing-Butterfly, 2.4.3.4.10.1 Alias Reduction, Table B.9
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN OUT) :: x(:, :) ! x(32, 18)
REAL (KIND = 8) :: tmp1, tmp2
INTEGER :: iband, k
DO iband = 1, SIZE(x, 1) - 1
 DO k = 0, 7
  tmp1 = x(iband    , 18 - k)
  tmp2 = x(iband + 1,  1 + k)
  x(iband    , 18 - k) =  tmp1 * cs(k) + tmp2 * ca(k)
  x(iband + 1,  1 + k) =  tmp2 * cs(k) - tmp1 * ca(k)
 END DO
END DO
RETURN
END SUBROUTINE anti_alias
!--------------------------------------------------------------------------------------------------
SUBROUTINE mdct36(x_in, x_out) ! ISO C.1.5.3.3 MDCT:   ! MDCT(4n) <=> FFT(n) proof: http://members.at.infoseek.co.jp/kitaurawa/mdct.pdf   (JP)
IMPLICIT NONE                                          !                            http://members.at.infoseek.co.jp/kitaurawa/mdct_e.pdf (E)
REAL (KIND = 8), INTENT(IN ) :: x_in (:) ! 36
REAL (KIND = 8), INTENT(OUT) :: x_out(:) ! 18
REAL (KIND = 8):: x_shift(36), x_re, x_im
COMPLEX (KIND = 8):: fft(9)
INTEGER:: i
x_shift( 1: 9) = -x_in(28:36)
x_shift(10:36) =  x_in( 1:27)
DO i = 1, 9
 x_re = x_shift(2 * i -  1) - x_shift(38 - 2 * i)
 x_im = x_shift(2 * i + 17) - x_shift(20 - 2 * i)
 fft(i) = CMPLX(x_re, x_im, KIND = 8) * omega9s(i)
END DO
CALL fft9(fft)
fft = fft * omega9s
DO i = 1, 9
 x_out(2 * i - 1) =  REAL(      fft(i)      , KIND = 8)
 x_out(2 * i    ) =  REAL(AIMAG(fft(10 - i)), KIND = 8)
END DO
RETURN
END SUBROUTINE mdct36
!---------------------------------------------------------------------------------------------------
SUBROUTINE fft9(fft) ! FFT of 3^n (n=2)
IMPLICIT NONE
COMPLEX (KIND = 8), INTENT(IN OUT):: fft(:)
COMPLEX (KIND = 8) :: c1, c2, c3, c4, tmp1, tmp2, tmp3
INTEGER, PARAMETER :: nn = 9
INTEGER :: i, j, iphase1, iphase2, m1, m2, m3, k3, kn3
fft = fft(indx9) / 9.0d0 ! reorder and normalize
DO k3 = 1, 2 ! 3^n (n=2)
 kn3 = 3**(k3 - 1)
 DO i = 1, nn, 3 * kn3
  DO j = 1, kn3
   iphase1 = 3**(2 - k3) * (j - 1)
   iphase2 = 2 * iphase1
   c1 = omega9( MOD(iphase1, nn) )
   c2 = omega9( MOD(iphase2, nn) )
   m1 = i + j - 1
   m2 = m1 + kn3
   m3 = m2 + kn3
   tmp1 =      fft(m1)
   tmp2 = c1 * fft(m2)
   tmp3 = c2 * fft(m3)
   fft(m1) = tmp1 + tmp2 + tmp3
   c3 = tmp1 - 0.5d0 * ( tmp2 + tmp3 )
   c4 =     sqrt3_2  * ( tmp2 - tmp3 ) ! sqrt3_2 = i sqrt(3) / 2
   fft(m2) = c3 + c4
   fft(m3) = c3 - c4
  END DO
 END DO
END DO
RETURN
END SUBROUTINE fft9
!-----------------------------------------------------------------------
SUBROUTINE fft9_initialize()
IMPLICIT NONE
INTEGER :: i, j, k, n
pi = 4.0d0 * ATAN(1.0d0)
sqrt3_2 = CMPLX(0.0d0, SQRT(0.75d0), KIND = 8) ! iSQRT(3) / 2
DO i = 1, 9
 n = 0
 k = i - 1
 DO j = 2 - 1, 0, -1
  n = n + MOD(k, 3) * 3**j
  k = k / 3
 END DO
 indx9(i) = n + 1
 !omega9(i - 1) = EXP( CMPLX(0.0d0, 2.0d0 * pi /  9.0d0 * REAL(i - 1, KIND = 8), KIND = 8) )
 !omega9s(i)    = EXP( CMPLX(0.0d0, 2.0d0 * pi / 36.0d0 * ( 1.0d0 / 8.0d0 + REAL(i - 1, KIND = 8) ), KIND = 8) )
 omega9(i - 1) = CMPLX( COS( REAL( 2 * i - 2, KIND = 8) /   9.0d0 * pi ),   &
                        SIN( REAL( 2 * i - 2, KIND = 8) /   9.0d0 * pi ), KIND = 8 )
 omega9s(i)    = CMPLX( COS( REAL( 8 * i - 7, KIND = 8) / 144.0d0 * pi ), &
                        SIN( REAL( 8 * i - 7, KIND = 8) / 144.0d0 * pi ), KIND = 8 )
END DO
RETURN
END SUBROUTINE fft9_initialize
!-----------------------------------------------------------------------
SUBROUTINE mdct12(x_in, x_out)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: x_in (:) ! 12
REAL (KIND = 8), INTENT(OUT) :: x_out(:) !  6
REAL (KIND = 8):: x_shift(12), x_re, x_im
COMPLEX (KIND = 8):: fft(3)
INTEGER:: i
x_shift( 1: 3) = -x_in(10:12)
x_shift( 4:12) =  x_in( 1: 9)
DO i = 1, 3
 x_re = x_shift(2 * i - 1) - x_shift(14 - 2 * i)
 x_im = x_shift(2 * i + 5) - x_shift( 8 - 2 * i)
 fft(i) = CMPLX(x_re, x_im, KIND = 8) * omega3s(i)
END DO
CALL fft3(fft)
fft = fft * omega3s
DO i = 1, 3
 x_out(2 * i - 1) =  REAL(      fft(i)     , KIND = 8)
 x_out(2 * i    ) =  REAL(AIMAG(fft(4 - i)), KIND = 8)
END DO
RETURN
END SUBROUTINE mdct12
!-----------------------------------------------------------------------
SUBROUTINE fft3(fft)
IMPLICIT NONE
COMPLEX (KIND = 8), INTENT(IN OUT):: fft(:)
COMPLEX (KIND = 8) :: c2, c3, c4
c2 = fft(2) + fft(3)
c3 = fft(1) - 0.5d0 * c2
c4 = sqrt3_2 * ( fft(2) - fft(3) ) ! sqrt3_2 = i sqrt(3) / 2
fft(1) = fft(1) + c2
fft(2) = c3 + c4
fft(3) = c3 - c4
fft = fft / 3.0d0 ! normalization
RETURN
END SUBROUTINE fft3
!--------------------------------------------------------------------------------------------------
SUBROUTINE fft3_initialize()
IMPLICIT NONE
INTEGER :: i
pi = 4.0d0 * ATAN(1.0d0)
sqrt3_2 = CMPLX(0.0d0, SQRT(0.75d0), KIND = 8) ! iSQRT(3) / 2
DO i = 1, 3
 !omega3(i - 1) = EXP( CMPLX(0.0d0, 2.0d0 * pi /  3.0d0 * REAL(i - 1, KIND = 8), KIND = 8) )
 !omega3s(i)    = EXP( CMPLX(0.0d0, 2.0d0 * pi / 12.0d0 * ( 1.0d0 / 8.0d0 + REAL(i - 1, KIND = 8) ), KIND = 8) )
 omega3(i - 1) = CMPLX( COS( REAL( 2 * i - 2, KIND = 8) /  3.0d0 * pi ),   &
                        SIN( REAL( 2 * i - 2, KIND = 8) /  3.0d0 * pi ), KIND = 8 )
 omega3s(i)    = CMPLX( COS( REAL( 8 * i - 7, KIND = 8) / 48.0d0 * pi ),   &
                        SIN( REAL( 8 * i - 7, KIND = 8) / 48.0d0 * pi ), KIND = 8 )
END DO
RETURN
END SUBROUTINE fft3_initialize
!-----------------------------------------------------------------------
END MODULE mod_mdct


!
! Liu Ocean Permittivity module.
!
! Module containing routines to compute the complex permittivities for
! sea water based on
!
!   Liu, Q. et al. (2010) An improved fast microwave water emissivity model.
!      IEEE Trans. Geosci. Remote Sensing, accepted June 25, 2010
!
!
! CREATION HISTORY:
!       Written by:     Quanhua (Mark) Liu, JCSDA 30-Jul-2009
!                       Quanhua.Liu@noaa.gov

MODULE Liu

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE CSEM_Type_Kinds, ONLY: fp => CSEM_fp
  USE CRTM_FASTEM_Constants, ONLY: PI, &
                                   E0 => PERMITTIVITY, &  ! Permittivity of vacuum (F/m)
                                   K_TO_C => STANDARD_TEMPERATURE ! Temperature units conversion
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! ... Datatypes
  PUBLIC :: iVar_type
  ! ... Procedures
  PUBLIC :: Liu_Ocean_Permittivity
  PUBLIC :: Liu_Ocean_Permittivity_TL
  PUBLIC :: Liu_Ocean_Permittivity_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id: Liu.f90 12622 2011-03-03 23:45:25Z paul.vandelst@noaa.gov $'

  ! Literal constants
  ! -----------------
  REAL(fp), PARAMETER :: ZERO   = 0.0_fp
  REAL(fp), PARAMETER :: ONE    = 1.0_fp
  REAL(fp), PARAMETER :: TWO    = 2.0_fp
  REAL(fp), PARAMETER :: THREE  = 3.0_fp
  REAL(fp), PARAMETER :: FOUR   = 4.0_fp

  ! Scaling factors
  ! ---------------
  REAL(fp), PARAMETER :: GHZ_TO_HZ = 1.0e+09_fp ! Gigahertz   -> Hertz

  ! Fixed value for ionic conductivity denominator term, scaled
  ! for frequency. See the last term of eqn.(3) in reference.
  ! -----------------------------------------------------------
  REAL(fp), PARAMETER :: TAU0 = TWO*PI*E0*GHZ_TO_HZ

  ! Parameters for the Liu et al (2010) permittivity model
  ! ------------------------------------------------------
  ! The coefficients for the high-frequency permittivity temperature
  ! polynomial. Eqn.(4a) in reference.
  REAL(fp), PARAMETER :: EINF_COEFF(0:1) = (/ 3.8_fp, &
                                              2.48033e-02_fp /)

  ! The coefficients for the static permittivity temperature
  ! and salinity polynomials. Eqn.(4b) in reference.
  REAL(fp), PARAMETER :: ES_T_COEFF(0:3) = (/ 87.9181727_fp      , &
                                              -4.031592248e-01_fp, &
                                               9.493088010e-04_fp, &
                                              -1.930858348E-06_fp /)
  REAL(fp), PARAMETER :: ES_S_COEFF(0:2) = (/-2.697e-03_fp, &
                                             -7.3E-06_fp  , &
                                             -8.9E-06_fp   /)

  ! The coefficients for the intermediate frequency permittivity
  ! temperature and salinity polynomials. Eqn.(4c) in reference.
  REAL(fp), PARAMETER :: E1_T_COEFF(0:2) = (/ 5.723_fp     , &
                                              2.2379e-02_fp, &
                                             -7.1237e-04_fp /)
  REAL(fp), PARAMETER :: E1_S_COEFF(0:2) = (/-6.28908E-03_fp, &
                                              1.76032E-04_fp, &
                                             -9.22144E-05_fp /)

  ! The coefficients for the relaxation time temperature and
  ! salinity polynomials. Eqns.(4e) and (4f) in reference.
  REAL(fp), PARAMETER :: TAU1_T_COEFF(0:3) = (/ 1.124465e-01_fp , &
                                               -3.9815727e-03_fp, &
                                                8.113381e-05_fp , &
                                               -7.1824242e-07_fp /)
  REAL(fp), PARAMETER :: TAU1_S_COEFF(0:2) = (/-2.39357E-03_fp, &
                                                3.1353E-05_fp , &
                                               -2.52477E-07_fp /)

  REAL(fp), PARAMETER :: TAU2_T_COEFF(0:3) = (/ 3.049979018e-03_fp, &
                                               -3.010041629E-05_fp, &
                                                4.811910733E-06_fp, &
                                               -4.259775841E-08_fp /)
  REAL(fp), PARAMETER :: TAU2_S_COEFF(0:2) = (/ 1.49e-01_fp, &
                                               -8.8E-04_fp , &
                                               -1.05E-04_fp /)

  ! The coefficients for the ionic conductivity exponential.
  ! Eqn.(4g) in reference.
  REAL(fp), PARAMETER :: ALPHA_COEFF = -4.259775841E-08_fp

  ! The coefficients for the ionic conductivity exponent term
  ! polynomial. Eqn.(4i) in reference.
  REAL(fp), PARAMETER :: BETA_COEFF(0:5) = (/ 2.033E-02_fp, &
                                              1.266E-04_fp, &
                                              2.464E-06_fp, &
                                             -1.849E-05_fp, &
                                              2.551E-07_fp, &
                                             -2.551E-08_fp /)

  ! The coefficients for the ionic conductivity at 25C polynomial.
  ! Eqn.(4j) in reference.
  REAL(fp), PARAMETER :: ALPHA25_COEFF(0:3) = (/ 1.82521e-01_fp, &
                                                -1.46192E-03_fp, &
                                                 2.09324E-05_fp, &
                                                -1.28205E-07_fp /)

  ! --------------------------------------
  ! Structure definition to hold forward
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: iVar_type
    PRIVATE
    REAL(fp) :: t=ZERO                             ! Temperature in deg.C
    REAL(fp) :: s=ZERO                             ! Salinity
    REAL(fp) :: delta=ZERO, beta=ZERO              ! Ionic conductivity components
    REAL(fp) :: alpha25=ZERO, alpha=ZERO           ! Ionic conductivity terms
    REAL(fp) :: es_t=ZERO, es_s=ZERO               ! The temperature and salinity es terms
    REAL(fp) :: e1_t=ZERO, e1_s=ZERO               ! The temperature and salinity e1 terms
    REAL(fp) :: tau1_t=ZERO, tau1_s=ZERO           ! The temperature and salinity tau1 terms
    REAL(fp) :: tau2_t=ZERO, tau2_s=ZERO           ! The temperature and salinity tau2 terms
    REAL(fp) :: f1=ZERO, f2=ZERO                   ! The relaxation compound terms, f.tau
    REAL(fp) :: del1=ZERO, del2=ZERO               ! The permittivity differences
  END TYPE iVar_type

CONTAINS

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Liu_Ocean_Permittivity
!
! PURPOSE:
!       Subroutine to compute ocean permittivity according to the reference,
!         Liu, Q. et al. (2010) An improved fast microwave water emissivity model.
!            IEEE Trans. Geosci. Remote Sensing, accepted June 25, 2010
!
! CALLING SEQUENCE:
!       CALL Liu_Ocean_Permittivity( Temperature , & ! Input
!                                    Salinity    , & ! Input
!                                    Frequency   , & ! Input
!                                    Permittivity, & ! Output
!                                    iVar          ) ! Internal variable output
!
! INPUTS:
!       Temperature:   Sea surface temperature
!                      UNITS:      Kelvin (K)
!                      TYPE:       REAL(fp)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
!       Salinity:      Water salinity
!                      UNITS:      ppt (parts per thousand)
!                      TYPE:       REAL(fp)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
!       Frequency:     Frequency
!                      UNITS:      GHz
!                      TYPE:       REAL(fp)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Permittivity:  Ocean permittivity
!                      UNITS:      N/A
!                      TYPE:       COMPLEX(fp)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
!       iVar:          Structure containing internal variables required for
!                      subsequent tangent-linear or adjoint model calls.
!                      The contents of this structure are NOT accessible
!                      outside of this module.
!                      UNITS:      N/A
!                      TYPE:       TYPE(iVar_type)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Liu_Ocean_Permittivity( &
    Temperature , & ! Input
    Salinity    , & ! Input
    Frequency   , & ! Input
    Permittivity, & ! Output
    iVar          ) ! Internal variable output
    ! Arguments
    REAL(fp),        INTENT(IN)     :: Temperature
    REAL(fp),        INTENT(IN)     :: Salinity
    REAL(fp),        INTENT(IN)     :: Frequency
    COMPLEX(fp),     INTENT(OUT)    :: Permittivity
    TYPE(iVar_type), INTENT(IN OUT) :: iVar
    ! Local variables
    REAL(fp) :: einf
    REAL(fp) :: tau1, tau2, es, e1
    REAL(fp) :: re, ie

    ! Setup
    ! -----
    ! ...Initialise imaginary component of result
    ie = ZERO
    ! ...Save the inputs
    iVar%t = Temperature - K_TO_C
    iVar%s = Salinity

    ! Compute the TEMPERATURE polynomial parameterisations
    ! ----------------------------------------------------
    ! ...The high-frequency permittivity temperature polynomial (eqn.4a)
    einf = EINF_COEFF(0) + iVar%t*EINF_COEFF(1)
    ! ...The static permittivity temperature polynomial (eqn.4b)
    es = ES_T_COEFF(0) + iVar%t*(ES_T_COEFF(1) + &
                           iVar%t*(ES_T_COEFF(2) + &
                             iVar%t*ES_T_COEFF(3)))
    iVar%es_t = es  ! Save it
    ! ...The intermediate frequency permittivity temperature polynomial (eqn.4c)
    e1 = E1_T_COEFF(0) + iVar%t*(E1_T_COEFF(1) + &
                           iVar%t*E1_T_COEFF(2))
    iVar%e1_t = e1  ! Save it
    ! ...The Debye relaxation time constants temperature polynomials (eqns.4e & 4f)
    ! ...Units of tau: nanoseconds (for use with GHz frequencies)
    tau1 = TAU1_T_COEFF(0) + iVar%t*(TAU1_T_COEFF(1) + &
                               iVar%t*(TAU1_T_COEFF(2) + &
                                 iVar%t*TAU1_T_COEFF(3)))
    iVar%tau1_t = tau1  ! Save it
    tau2 = TAU2_T_COEFF(0) + iVar%t*(TAU2_T_COEFF(1) + &
                               iVar%t*(TAU2_T_COEFF(2) + &
                                 iVar%t*TAU2_T_COEFF(3)))
    iVar%tau2_t = tau2  ! Save it

    ! Compute the SALINITY polynomial parameterisations
    ! -------------------------------------------------
    IF ( iVar%s > ZERO ) THEN
      ! ...The temperature difference from 25C (eqn.4h) used to compute ionic conductivity.
      iVar%delta = 25.0_fp - iVar%t
      ! ...The beta term (eqn.4i) used to compute ionic conductivity
      iVar%beta = BETA_COEFF(0) + iVar%delta*(BETA_COEFF(1) + &
                                    iVar%delta*BETA_COEFF(2)) + &
                  (BETA_COEFF(3) + iVar%delta*(BETA_COEFF(4) + &
                                     iVar%delta*BETA_COEFF(5)))*iVar%S
      ! ...The ionic conductivity at 25C (eqn.4j)
      iVar%alpha25 = iVar%s*(ALPHA25_COEFF(0) + &
                       iVar%s*(ALPHA25_COEFF(1) + &
                         iVar%s*(ALPHA25_COEFF(2) + &
                           iVar%s*ALPHA25_COEFF(3))))
      ! ...The ionic conductivity (eqn.4g)
      iVar%alpha = iVar%alpha25*EXP(-iVar%delta*iVar%beta)
      !  ...The imaginary component dependent on ionic conductivity (eqn.3)
      ie = -iVar%alpha/(Frequency*TAU0)

      ! ...The static permittivity salinity polynomial (eqn.4b)
      iVar%es_s = ONE + iVar%s*(ES_S_COEFF(0) + iVar%s*ES_S_COEFF(1) + iVar%t*ES_S_COEFF(2))
      es = es * iVar%es_s

      ! ...The intermediate frequency permittivity salinity polynomial (eqn.4c)
      iVar%e1_s = ONE + iVar%s*(E1_S_COEFF(0) + iVar%s*E1_S_COEFF(1) + iVar%t*E1_S_COEFF(2))
      e1 = e1 * iVar%e1_s

      ! ...The Debye relaxation time constants salinity polynomials (eqns.4e & 4f)
      ! ...Units of tau: nanoseconds (for use with GHz frequencies)
      iVar%tau1_s = ONE + iVar%s*(TAU1_S_COEFF(0) + iVar%t*(TAU1_S_COEFF(1) + &
                                                      iVar%t*TAU1_S_COEFF(2)))
      tau1 = tau1 * iVar%tau1_s
      iVar%tau2_s = ONE + iVar%s*(TAU2_S_COEFF(0) + iVar%t*TAU2_S_COEFF(1) + &
                                                    (iVar%s**2)*TAU2_S_COEFF(2))
      tau2 = tau2 * iVar%tau2_s

    END IF

    ! Compute the complex permittivity
    ! --------------------------------
    ! ...The compound terms
    iVar%f1 = Frequency*tau1  ! Note there is no GHz->Hz conversion.
    iVar%f2 = Frequency*tau2  ! That is embedded in the tau values.
    iVar%del1 = es - e1
    iVar%del2 = e1 - einf
    ! ...The real part
    re = einf + iVar%del1/(ONE + iVar%f1**2) + &
                iVar%del2/(ONE + iVar%f2**2)
    ! ...The imaginary part
    ie = -ie + iVar%del1*iVar%f1/(ONE + iVar%f1**2) + &
               iVar%del2*iVar%f2/(ONE + iVar%f2**2)
    ! ...Combine them (e = re - j.ie)
    Permittivity = CMPLX(re,-ie,fp)

  END SUBROUTINE Liu_Ocean_Permittivity

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Liu_Ocean_Permittivity_TL
!
! PURPOSE:
!       Subroutine to compute the tangent-linear ocean permittivity according
!       to the model in the reference,
!         Liu, Q. et al. (2010) An improved fast microwave water emissivity model.
!            IEEE Trans. Geosci. Remote Sensing, accepted June 25, 2010
!
! CALLING SEQUENCE:
!       CALL Liu_Ocean_Permittivity_TL( Temperature_TL , &  ! TL Input
!                                       Salinity_TL    , &  ! TL Input
!                                       Frequency      , &  ! Invariant Input
!                                       Permittivity_TL, &  ! TL Output
!                                       iVar             )  ! Internal variable input
!
! INPUTS:
!       Temperature_TL:  Tangent-linear sea surface temperature.
!                        UNITS:      Kelvin (K)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Salinity_TL:     Tangent-linear water salinity.
!                        UNITS:      ppt (parts per thousand)
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Frequency:       Frequency
!                        UNITS:      GHz
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       iVar:            Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of this module.
!                        UNITS:      N/A
!                        TYPE:       TYPE(iVar_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Permittivity_TL: Tangent-linear permittivity
!                        UNITS:      N/A
!                        TYPE:       COMPLEX(fp)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(OUT)
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Liu_Ocean_Permittivity_TL( &
    Temperature_TL , &  ! TL Input
    Salinity_TL    , &  ! TL Input
    Frequency      , &  ! Invariant input
    Permittivity_TL, &  ! TL Output
    iVar             )  ! Internal variable input
    ! Arguments
    REAL(fp),        INTENT(IN)  :: Temperature_TL
    REAL(fp),        INTENT(IN)  :: Salinity_TL
    REAL(fp),        INTENT(IN)  :: Frequency
    COMPLEX(fp),     INTENT(OUT) :: Permittivity_TL
    TYPE(iVar_type), INTENT(IN)  :: iVar

    ! Local variables
    REAL(fp) :: einf_TL
    REAL(fp) :: es_s_TL, es_TL
    REAL(fp) :: e1_s_TL, e1_TL
    REAL(fp) :: tau1_s_TL, tau1_TL
    REAL(fp) :: tau2_s_TL, tau2_TL
    REAL(fp) :: delta_TL, beta_TL
    REAL(fp) :: alpha25_TL, alpha_TL
    REAL(fp) :: f1_TL, f2_TL, del1_TL, del2_TL
    REAL(fp) :: x1, x2
    REAL(fp) :: re_TL, ie_TL

    ! Setup
    ! -----
    ! ...Initialise imaginary component of result
    ie_TL = ZERO

    ! Compute the tangent-linear TEMPERATURE polynomial parameterisations
    ! -------------------------------------------------------------------
    ! ...The high-frequency permittivity temperature polynomial (eqn.4a)
    einf_TL = EINF_COEFF(1)*Temperature_TL
    ! ...The static permittivity temperature polynomial (eqn.4b)
    es_TL = (ES_T_COEFF(1) + iVar%t*(TWO*ES_T_COEFF(2) + &
                               iVar%t*THREE*ES_T_COEFF(3))) * Temperature_TL
    ! ...The intermediate frequency permittivity temperature polynomial (eqn.4c)
    e1_TL = (E1_T_COEFF(1) + iVar%t*TWO*E1_T_COEFF(2)) * Temperature_TL
    ! ...The Debye relaxation time constants temperature polynomials (eqns.4e & 4f)
    ! ...Units of tau: nanoseconds (for use with GHz frequencies)
    tau1_TL = (TAU1_T_COEFF(1) + iVar%t*(TWO*TAU1_T_COEFF(2) + &
                                   iVar%t*THREE*TAU1_T_COEFF(3))) * Temperature_TL
    tau2_TL = (TAU2_T_COEFF(1) + iVar%t*(TWO*TAU2_T_COEFF(2) + &
                                   iVar%t*THREE*TAU2_T_COEFF(3))) * Temperature_TL

    ! Compute the SALINITY polynomial parameterisations
    ! -------------------------------------------------
    IF ( iVar%s > ZERO ) THEN
      ! ...The temperature difference from 25C (eqn.4h) used to compute ionic conductivity.
      delta_TL = -Temperature_TL
      ! ...The beta term (eqn.4i) used to compute ionic conductivity
      beta_TL = (BETA_COEFF(1) + iVar%delta*TWO*BETA_COEFF(2) + &
                 iVar%s*(BETA_COEFF(4) + iVar%delta*TWO*BETA_COEFF(5)))*delta_TL + &
                (BETA_COEFF(3) + iVar%delta*(BETA_COEFF(4) + &
                                   iVar%delta*BETA_COEFF(5)))*Salinity_TL
      ! ...The ionic conductivity at 25C (eqn.4j)
      alpha25_TL = (ALPHA25_COEFF(0) + &
                     iVar%s*(TWO*ALPHA25_COEFF(1) + &
                       iVar%s*(THREE*ALPHA25_COEFF(2) + &
                         iVar%s*FOUR*ALPHA25_COEFF(3))))*Salinity_TL
      ! ...The ionic conductivity (eqn.4g)
      alpha_TL = (alpha25_TL/iVar%alpha25 - iVar%delta*beta_TL - iVar%beta*delta_TL)*iVar%alpha
      !  ...The imaginary component dependent on ionic conductivity (eqn.3)
      ie_TL = -alpha_TL/(Frequency*TAU0)

      ! ...The static permittivity salinity polynomial (eqn.4b)
      es_s_TL = (ES_S_COEFF(0) + iVar%s*TWO*ES_S_COEFF(1) + iVar%t*ES_S_COEFF(2))*Salinity_TL + &
                iVar%s*ES_S_COEFF(2)*Temperature_TL
      es_TL = iVar%es_t*es_s_TL + iVar%es_s*es_TL

      ! ...The intermediate frequency permittivity salinity polynomial (eqn.4c)
      e1_s_TL = (E1_S_COEFF(0) + iVar%s*TWO*E1_S_COEFF(1) + iVar%t*E1_S_COEFF(2))*Salinity_TL + &
                iVar%s*E1_S_COEFF(2)*Temperature_TL
      e1_TL = iVar%e1_t*e1_s_TL + iVar%e1_s*e1_TL

      ! ...The Debye relaxation time constants salinity polynomials (eqns.4e & 4f)
      ! ...Units of tau: nanoseconds (for use with GHz frequencies)
      tau1_s_TL = (TAU1_S_COEFF(0) + iVar%t*(TAU1_S_COEFF(1) + &
                                       iVar%t*TAU1_S_COEFF(2)))*Salinity_TL + &
                  iVar%s*(TAU1_S_COEFF(1) + iVar%t*TWO*TAU1_S_COEFF(2))*Temperature_TL
      tau1_TL = iVar%tau1_t*tau1_s_TL + iVar%tau1_s*tau1_TL

      tau2_s_TL = (TAU2_S_COEFF(0) + iVar%t*TAU2_S_COEFF(1) + &
                                     (iVar%s**2)*THREE*TAU2_S_COEFF(2))*Salinity_TL + &
                  iVar%s*TAU2_S_COEFF(1)*Temperature_TL
      tau2_TL = iVar%tau2_t*tau2_s_TL + iVar%tau2_s*tau2_TL

    END IF

    ! Compute the complex permittivity
    ! --------------------------------
    ! ...The compound terms
    f1_TL = Frequency*tau1_TL  ! Note there is no GHz->Hz conversion.
    f2_TL = Frequency*tau2_TL  ! That is embedded in the tau values.
    del1_TL = es_TL - e1_TL
    del2_TL = e1_TL - einf_TL
    ! ...Calculate the denominator terms
    x1 = ONE + iVar%f1**2
    x2 = ONE + iVar%f2**2
    ! ...The real part
    re_TL = einf_TL + &
            (x1*del1_TL - iVar%del1*iVar%f1*TWO*f1_TL)/x1**2 + &
            (x2*del2_TL - iVar%del2*iVar%f2*TWO*f2_TL)/x2**2
    ! ...The imaginary part
    ie_TL = iVar%f1*del1_TL/x1 + &
            iVar%del1*(ONE - iVar%f1**2)*f1_TL/x1**2 + &
            iVar%f2*del2_TL/x2 + &
            iVar%del2*(ONE - iVar%f2**2)*f2_TL/x2**2 - &
            ie_TL
    ! ...Combine them (e = re - j.ie)
    Permittivity_TL = CMPLX(re_TL,-ie_TL,fp)

  END SUBROUTINE Liu_Ocean_Permittivity_TL

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Liu_Ocean_Permittivity_AD
!
! PURPOSE:
!       Subroutine to compute the ocean permittivity adjoint according to the
!       model in the reference,
!         Liu, Q. et al. (2010) An improved fast microwave water emissivity model.
!            IEEE Trans. Geosci. Remote Sensing, accepted June 25, 2010
!
! CALLING SEQUENCE:
!       CALL Liu_Ocean_Permittivity_AD( Permittivity_AD, &  ! AD Input
!                                       Frequency      , &  ! Invariant Input
!                                       Temperature_AD , &  ! AD Output
!                                       Salinity_AD    , &  ! AD Output
!                                       iVar             )  ! Internal variable input
!
! INPUTS:
!       Permittivity_AD:  Adjoint ocean permittivity
!                         *** SET TO ZERO UPON EXIT ***
!                         UNITS:      N/A
!                         TYPE:       COMPLEX(fp)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
!       Frequency:        Frequency
!                         UNITS:      GHz
!                         TYPE:       REAL(fp)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
!       iVar:             Structure containing internal variables required for
!                         subsequent tangent-linear or adjoint model calls.
!                         The contents of this structure are NOT accessible
!                         outside of this module.
!                         UNITS:      N/A
!                         TYPE:       TYPE(iVar_type)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Temperature_AD:   Adjoint sea surface temperature, de/dT.
!                         *** MUST HAVE VALUE UPON ENTRY ***
!                         UNITS:      per Kelvin (K^-1)
!                         TYPE:       REAL(fp)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
!       Salinity_AD:      Adjoint water salinity, de/dS
!                         *** MUST HAVE VALUE UPON ENTRY ***
!                         UNITS:      per ppt (parts-per-thousand^-1)
!                         TYPE:       REAL(fp)
!                         DIMENSION:  Scalar
!                         ATTRIBUTES: INTENT(IN OUT)
!
! SIDE EFFECTS:
!       The input adjoint variable, Permittivity_AD, is set to zero upon
!       exiting this routine.
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Liu_Ocean_Permittivity_AD( &
    Permittivity_AD, & ! AD Input
    Frequency      , & ! Invariant Input
    Temperature_AD , & ! AD Output
    Salinity_AD    , & ! AD Output
    iVar             ) ! Internal variable input
    IMPLICIT NONE
    ! Arguments
    COMPLEX(fp),     INTENT(IN OUT) :: Permittivity_AD
    REAL(fp),        INTENT(IN)     :: Frequency
    REAL(fp),        INTENT(IN OUT) :: Temperature_AD
    REAL(fp),        INTENT(IN OUT) :: Salinity_AD
    TYPE(iVar_type), INTENT(IN)     :: iVar
    ! Local variables
    REAL(fp) :: re_AD, ie_AD
    REAL(fp) :: x1, x2
    REAL(fp) :: f1_AD, f2_AD, del1_AD, del2_AD
    REAL(fp) :: delta_AD, beta_AD
    REAL(fp) :: alpha25_AD, alpha_AD
    REAL(fp) :: tau1_s_AD, tau1_AD
    REAL(fp) :: tau2_s_AD, tau2_AD
    REAL(fp) :: einf_AD
    REAL(fp) :: es_s_AD, es_AD
    REAL(fp) :: e1_s_AD, e1_AD

    ! Complex permittivity
    ! --------------------
    ! ...Separate the real and imaginary parts
    ie_AD = -AIMAG(Permittivity_AD)
    re_AD = REAL(Permittivity_AD, fp)
    Permittivity_AD = ZERO
    ! ...Calculate the denominator terms
    x1 = ONE + iVar%f1**2
    x2 = ONE + iVar%f2**2
    ! ...The imaginary part
    f2_AD = iVar%del2*(ONE - iVar%f2**2)*ie_AD/x2**2
    del2_AD = iVar%f2*ie_AD/x2
    f1_AD = iVar%del1*(ONE - iVar%f1**2)*ie_AD/x1**2
    del1_AD = iVar%f1*ie_AD/x1
    ie_AD = -ie_AD
    ! ...The real part
    f2_AD = f2_AD - (iVar%del2*iVar%f2*TWO*re_AD)/x2**2
    del2_AD = del2_AD + re_AD/x2
    f1_AD = f1_AD - (iVar%del1*iVar%f1*TWO*re_AD)/x1**2
    del1_AD = del1_AD + re_AD/x1
    einf_AD = re_AD
    ! ...The compound terms
    einf_AD = einf_AD - del2_AD
    e1_AD = del2_AD
    e1_AD = e1_AD - del1_AD
    es_AD = del1_AD
    tau2_AD = Frequency*f2_AD
    tau1_AD = Frequency*f1_AD

    ! Compute the SALINITY polynomial parameterisations
    ! -------------------------------------------------
    IF ( iVar%s > ZERO ) THEN
      ! ...The Debye relaxation time constants salinity polynomials (eqns.4e & 4f)
      ! ...Units of tau: nanoseconds (for use with GHz frequencies)
      tau2_s_AD = iVar%tau2_t*tau2_AD
      tau2_AD   = iVar%tau2_s*tau2_AD
      Salinity_AD = Salinity_AD + &
                    (TAU2_S_COEFF(0) + iVar%t*TAU2_S_COEFF(1) + &
                                       (iVar%s**2)*THREE*TAU2_S_COEFF(2))*tau2_s_AD
      Temperature_AD = Temperature_AD + &
                       iVar%s*TAU2_S_COEFF(1)*tau2_s_AD

      tau1_s_AD = iVar%tau1_t*tau1_AD
      tau1_AD   = iVar%tau1_s*tau1_AD
      Salinity_AD = Salinity_AD + &
                    (TAU1_S_COEFF(0) + iVar%t*(TAU1_S_COEFF(1) + &
                                       iVar%t*TAU1_S_COEFF(2)))*tau1_s_AD
      Temperature_AD = Temperature_AD + &
                       iVar%s*(TAU1_S_COEFF(1) + iVar%t*TWO*TAU1_S_COEFF(2))*tau1_s_AD

      ! ...The intermediate frequency permittivity salinity polynomial (eqn.4c)
      e1_s_AD = iVar%e1_t*e1_AD
      e1_AD   = iVar%e1_s*e1_AD
      Salinity_AD = Salinity_AD + &
                    (E1_S_COEFF(0) + iVar%s*TWO*E1_S_COEFF(1) + iVar%t*E1_S_COEFF(2))*e1_s_AD
      Temperature_AD = Temperature_AD + &
                       iVar%s*E1_S_COEFF(2)*e1_s_AD

      ! ...The static permittivity salinity polynomial (eqn.4b)
      es_s_AD = iVar%es_t*es_AD
      es_AD   = iVar%es_s*es_AD
      Salinity_AD = Salinity_AD + &
                    (ES_S_COEFF(0) + iVar%s*TWO*ES_S_COEFF(1) + iVar%t*ES_S_COEFF(2))*es_s_AD
      Temperature_AD = Temperature_AD + &
                       iVar%s*ES_S_COEFF(2)*es_s_AD

      !  ...The imaginary component dependent on ionic conductivity (eqn.3)
      alpha_AD = -ie_AD/(Frequency*TAU0)
      ! ...The ionic conductivity (eqn.4g)
      alpha25_AD = iVar%alpha*alpha_AD/iVar%alpha25
      beta_AD  = -iVar%delta*iVar%alpha*alpha_AD
      delta_AD = -iVar%beta*iVar%alpha*alpha_AD
      ! ...The ionic conductivity at 25C (eqn.4j)
      Salinity_AD = Salinity_AD + &
                    (ALPHA25_COEFF(0) + &
                     iVar%s*(TWO*ALPHA25_COEFF(1) + &
                       iVar%s*(THREE*ALPHA25_COEFF(2) + &
                         iVar%s*FOUR*ALPHA25_COEFF(3))))*alpha25_AD
      ! ...The beta term (eqn.4i) used to compute ionic conductivity
      Salinity_AD = Salinity_AD + &
                    (BETA_COEFF(3) + iVar%delta*(BETA_COEFF(4) + &
                                       iVar%delta*BETA_COEFF(5)))*beta_AD
      delta_AD = delta_AD + &
                 (BETA_COEFF(1) + iVar%delta*TWO*BETA_COEFF(2) + &
                 (BETA_COEFF(4) + iVar%delta*TWO*BETA_COEFF(5))*iVar%s)*beta_AD
      ! ...The temperature difference from 25C (eqn.4h) used to compute ionic conductivity.
      Temperature_AD = Temperature_AD - delta_AD
    END IF

    ! ...The Debye relaxation time constants temperature polynomials (eqns.4e & 4f)
    ! ...Units of tau: nanoseconds (for use with GHz frequencies)
    Temperature_AD = Temperature_AD + &
                     (TAU2_T_COEFF(1) + iVar%t*(TWO*TAU2_T_COEFF(2) + &
                                          iVar%t*THREE*TAU2_T_COEFF(3)))*tau2_AD
    Temperature_AD = Temperature_AD + &
                     (TAU1_T_COEFF(1) + iVar%t*(TWO*TAU1_T_COEFF(2) + &
                                          iVar%t*THREE*TAU1_T_COEFF(3)))*tau1_AD
    ! ...The intermediate frequency permittivity temperature polynomial (eqn.4c)
    Temperature_AD = Temperature_AD + &
                     (E1_T_COEFF(1) + iVar%t*TWO*E1_T_COEFF(2))*e1_AD
    ! ...The static permittivity salinity polynomial (eqn.4b)
    Temperature_AD = Temperature_AD + &
                     (ES_T_COEFF(1) + iVar%t*(TWO*ES_T_COEFF(2) + &
                                        iVar%t*THREE*ES_T_COEFF(3)))*es_AD
    ! ...The high-frequency permittivity temperature polynomial (eqn.4a)
    Temperature_AD = Temperature_AD + EINF_COEFF(1)*einf_AD

  END SUBROUTINE Liu_Ocean_Permittivity_AD

END MODULE Liu


!*************************************************************************
!int *nip, int *ntrian, double _Complex *zzsparse_tempt, double _Complex *crhs, int *q, int *p
SUBROUTINE hard_nys_oldBasis_SST(nip, ntrain, zzsparse,  m, n, local_nt, nb) bind(C, name="acoustic_generate_kernel")
! This subroutine fills zpast
  use, intrinsic :: iso_c_binding
  use global_com
  !use global_dim,only:JVector
  use global_geom,only:nsupan,sunod
  use gaussintegraldata
!  implicit none
  integer::i,j,p,q,k, counter, local_nt
  integer(c_int) ::ntrain
  integer(c_int) ::nip
  real(kind=dp)::vos1(2),vos2(2),vos3(2)
  real(kind=dp)::vcsio(2),vcsis(2),vcsik(2), quadPt(nlqp,2),quadWgt(nlqp,2)
  integer::nodeo_sn(nnpt),nodes_sn(nnpt)
  real(kind=dp)::vippo(3),vipps(3),vippsk(3),unitVec(3),unitVec0(3),unitVeck(3)
  real(kind=dp)::vros_ipp(3),ros_ipp,rpq_min
  real(kind=dp)::jacobo,jacobk,zeta10,zeta20,up0,vp0,nCapDotR,nCapDotRk,nCapDotRf,nCapDotRfk
  real(kind=dp)::vrrr(3),rrr ,vrrrk(3),rrrk ,vrrrf(3),rrrf,rpf(3),vrrrfk(3),rrrfk,rpfk(3)
  integer::ielement11,ielement12,ielement21,ielement22,ielement00
  complex(kind=dp)::z11,z12,z21,z22,z00, intVal,taylorSum
  real(kind=dp)::ipolator,ipolator0,ipolatort,ipolatork,quadPt_v(nclgp),quadWgt_v(nclgp)
  real(kind=dp)::vrr0(3),rr0,rNodes_src(3,nnpt),rNodes_field(3,nnpt),quadPt_u(nlqp),quadWgt_u(nlqp)
  integer::mode,nums(2)
  real(kind=dp)::coeffs(nipp,nipp),coeffo(nipp,nipp),rp0(3),jacobo0,jacobot
  complex(c_double_complex), dimension(nb*nb):: zzsparse
!  complex(c_double_complex), dimension(ntrain*nip):: JVector
  REAL(kind=dp),dimension(nipp)::JVector
!************************************************
 !allocate(JVector(1:nipp))
  vos1=(/1.0_dp,0.0_dp/)  !right angle triangle vertex points in (u,v) space
  vos2=(/0.0_dp,1.0_dp/)  !the first number is u value, the second number is v value
  vos3=(/0.0_dp,0.0_dp/)

  CALL findPolyCoeffs(alphas,betas,gammas,nipp,coeffs)
  CALL findPolyCoeffs(alphao,betao,gammao,nipp,coeffo)

  quadPt_u = xxo(:)
  quadPt_v = xxs(:)
  quadWgt_u = wwo(:)
  quadWgt_v = wws(:)
  nums = (/nlqp,nclgp/)

  quadPt(:,1) = xxo(:)
  quadPt(:,2) = xxs(:)
  quadWgt(:,1) = wwo(:)
  quadWgt(:,2) = wws(:)
!  counter =1
  counter =0
  gcount=0
  !PRINT*,m, n
!loop patches
  DO q=m,(m+local_nt-1)
    !here nsupan (nodeo_sn) is the six (observation) nodes for each patch
     nodeo_sn(:)=nsupan(:,q)  !serial numbers of field triangular patches
     rNodes_field(:,:) = sunod(:,nodeo_sn)
!     PRINT*,q,"of",ntriangle

    DO p=n,(n+local_nt-1)
        !here nsupan (nodes_sn) is the six (source) nodes for each patch
        nodes_sn(:)=nsupan(:,p)
        rNodes_src(:,:) = sunod(:,nodes_sn)

        IF(p.ne.q) THEN
            rpq_min=88888888.0_dp
            DO j=1,nipp
                vcsio = alphao(j)*vos1+betao(j)*vos2+gammao(j)*vos3
                CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)

                DO i=1,nipp
                    vcsis = alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
                    CALL mapGaussPtTo3Ddomain(vcsis(1),vcsis(2),nnpt,rNodes_src,vipps)
                    vros_ipp(:)=vippo(:)-vipps(:)
                    ros_ipp=SQRT(DOT_PRODUCT(vros_ipp,vros_ipp))
                    IF(ros_ipp.lt.rpq_min) rpq_min=ros_ipp
                ENDDO
            ENDDO

!*************************************************************************
 !far patch interaction
!*************************************************************************
           IF(rpq_min.gt.nearpd)  THEN   !far patch interaction
              !PRINT*,"computing for far-patch = ",p
              !counter=1
              DO j=1,nipp
                 ! ielement11=(q-1)*nipp+j
                  ielement11=j
                  vcsio = alphao(j)*vos1+betao(j)*vos2+gammao(j)*vos3
                  CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                  CALL calcJacobian(vcsio(1),vcsio(2),nnpt,rNodes_field,jacobot)
                  CALL basis_function(vcsio,nipp,coeffo,j,ipolatort)
                  JVector(ielement11)=1.0_dp/jacobot*ipolatort

                  DO i=1,nipp
                      !PRINT*,"i = ",i
                      !ielement00=((q-1)*nipp+j-1)*ntriangle*nipp+(p-1)*nipp+i
                      !ielement00=offset+counter
                      !ielement00=counter
                      !counter=counter+1
                      !ielement00=((j-1)*nb+i+counter)
                      ielement00=((i-1)*nb+j+counter)
                      vcsis = alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
                      CALL mapGaussPtTo3Ddomain(vcsis(1),vcsis(2),nnpt,rNodes_src,vipps)
                      CALL calcUnitNormal(vcsis(1),vcsis(2),nnpt,rNodes_src,unitVec)

                      vrrr(:)=vippo(:)-vipps(:)
                      rrr=SQRT(DOT_PRODUCT(vrrr,vrrr))        !|r-rp|
                      nCapDotR = DOT_PRODUCT(unitVec,vrrr)

!                      zzsparse(ielement00) = ws(i)*0.5_dp/(4.0_dp*pid)*nCapDotR*(exp(cjvk*rrr)*(1.0_dp-cjvk*rrr)/(rrr**3)) !matrix fill for far intraction
 IF ((p .eq. q) .AND.  (j .eq. i)) THEN
                      zzsparse(ielement00) = (ws(i)*0.5_dp/(4.0_dp*pid)*nCapDotR*(exp(cjvk*rrr)*(1.0_dp-cjvk*rrr)/(rrr**3)))&
-0.5_dp*JVector(ielement11) !matrix fill for far intraction
ELSE
                      zzsparse(ielement00) = ws(i)*0.5_dp/(4.0_dp*pid)*nCapDotR*(exp(cjvk*rrr)*(1.0_dp-cjvk*rrr)/(rrr**3))
   ENDIF
                  ENDDO

              ENDDO

!*************************************************************************
!near patch interaction...by setting higher degree gauss quadrature points for source triangle
!*************************************************************************
           ELSE
              !PRINT*,"computing for near-patch = ",p
              mode = 2
              !counter=1
              DO j=1,nipp
                  !PRINT*,"j = ",j
                  !ielement11=(q-1)*nipp+j
                  ielement11=j
                  vcsio = alphao(j)*vos1+betao(j)*vos2+gammao(j)*vos3
                  CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                  CALL calcJacobian(vcsio(1),vcsio(2),nnpt,rNodes_field,jacobot)
                  CALL basis_function(vcsio,nipp,coeffo,j,ipolatort)
                  JVector(ielement11)=1.0_dp/jacobot*ipolatort

                  DO i=1,nipp
                      !PRINT*,"i = ",i
                      !ielement00=((q-1)*nipp+j-1)*ntriangle*nipp+(p-1)*nipp+i
                      !ielement00=offset+counter
                      !ielement00=counter
                      !counter=counter+1
                      !ielement00=((j-1)*nb+i+counter)
                      ielement00=((i-1)*nb+j+counter)
                        z00 = (0.0_dp,0.0_dp)
                        DO k=1,nhdgqp_near
                              vcsik = alphas22(k)*vos1+betas22(k)*vos2+gammas22(k)*vos3
                              CALL mapGaussPtTo3Ddomain(vcsik(1),vcsik(2),nnpt,rNodes_src,vippsk)
                              CALL calcUnitNormal(vcsik(1),vcsik(2),nnpt,rNodes_src,unitVec)
                              CALL basis_function(vcsik,nipp,coeffs,i,ipolator)

                              vrrrk(:)=vippo(:)-vippsk(:)
                              rrrk=SQRT(DOT_PRODUCT(vrrrk,vrrrk))        !|r-rp|
                              nCapDotR = DOT_PRODUCT(unitVec,vrrrk)

                              z00 = z00 + ws22(k)*0.5_dp/(4.0_dp*pid)*nCapDotR*(exp(cjvk*rrrk)/&
                                               (rrrk**3))*(1.0_dp-cjvk*rrrk)*ipolator

                        ENDDO
     !                   zzsparse(ielement00) = z00
 IF ((p .eq. q) .AND.  (j .eq. i)) THEN
                        zzsparse(ielement00) = z00-0.5_dp*JVector(ielement11)
 Else
    zzsparse(ielement00) = z00
 ENDIF
                  ENDDO
               ENDDO

           ENDIF

!*************************************************************************
!self patch interaction...by applying Improved Guiggiani's method.
!*************************************************************************
        ELSE     !self patch interaction
              !PRINT*,"computing for self-patch = ",p
              !counter=1
              DO j=1,nipp
                  !PRINT*,"j = ",j
                  !ielement11=(q-1)*nipp+j
                  ielement11=j
                  vcsio = alphao(j)*vos1+betao(j)*vos2+gammao(j)*vos3
                  CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                  CALL calcJacobian(vcsio(1),vcsio(2),nnpt,rNodes_field,jacobot)
                  CALL basis_function(vcsio,nipp,coeffo,j,ipolatort)
                  JVector(ielement11)=1.0_dp/jacobot*ipolatort

                  DO i=1,nipp
                      !PRINT*,"i = ",i
                      !ielement00=((q-1)*nipp+j-1)*ntriangle*nipp+(p-1)*nipp+i
                      !ielement00=offset+counter
                      !ielement00=counter
                      !counter=counter+1
                      !ielement00=((j-1)*nb+i+counter)
                      ielement00=((i-1)*nb+j+counter)
                      CALL OriginalGuiggiani_hard(vcsio,nipp,nums,quadPt_u,quadWgt_u,&
                                                quadPt_v,quadWgt_v,coeffs,i,rNodes_field,nnpt,cjvk,z00)
     !                 zzsparse(ielement00) = z00

 IF ((p .eq. q) .AND.  (j .eq. i)) THEN
                      zzsparse(ielement00) = z00-0.5_dp*JVector(ielement11)
 ELSE
           zzsparse(ielement00) = z00
ENDIF
                  ENDDO
              ENDDO

        ENDIF
        counter=counter+local_nt*nipp*nipp
    ENDDO
     gcount=gcount+nipp
     counter=gcount
     !fortran but double check
     !counter=gcount+local_nt*nipp*nipp
     !gcount=gcount+local_nt*nipp*nipp

     !counter=gcount+nb*nipp
     !gcount=gcount+nb*nipp
  ENDDO

  !PRINT*,"Calculations for hard-boundary condition are done!"
  !  DEALLOCATE(JVector)
  RETURN

END SUBROUTINE hard_nys_oldBasis_SST
!*************************************************************************


{ -- MF/TIN CORE (always include) functions
  -- Copyright (c) 2003 by Jeff Massung }

\ inlined peek and poke values into GBA memory
icode-thumb peek 0 ( a -- h ) tos 0@ tos ldrh, end-code
icode-thumb peekb 0 ( a -- h ) tos 0@ tos ldrb, end-code
icode-thumb peekw 0 ( a -- h ) tos 0@ tos ldr, end-code

\ divide and modulo
:i / ( n1 n2 -- n3 ) swap a! 7 swi ;
:i mod ( n1 n2 -- n3 ) swap a! 7 swi drop a@ ;

code-thumb iwram 10/ ( n -- q )
	v0 v5 mov,
	15 ## tos v0 lsr,
	__recip eq? b,
	10 ## a mov,
	6 swi,
	v5 v0 mov,
	ret
	l: __recip
	3277 v0 LITERAL
	tos v0 mul,
	15 ## v0 v0 lsr,
	10 ## a mov,
	v0 a mul,
	a tos a sub,
	v0 tos mov,
	v5 v0 mov,
	ret
end-code

\ conditionals
:n = ( n1 n2 -- flag ) - 0= ;
:n <> ( n1 n2 -- flag ) - 0= com ;
:i < ( n1 n2 -- flag ) - 0< ;
:i > ( n1 n2 -- flag ) swap - 0< ;
:i <= ( n1 n2 -- flag ) swap - 0< com ;
:i >= ( n1 n2 -- flag ) - 0< com ;

\ fixed point math operations
:i f* ( n1 n2 -- n3 ) * 8 # a/ ;
:n f/ ( n1 n2 -- n3 ) a! 8 # n* 6 swi ;

\ the restore data pointer
variable .idata

\ transfer from data pointer to local address register
:i >a ( -- ) .idata @ a! ;

:i a> ( -- ) a@ .idata ! ;

\ allocate bytes of data on the return stack
code-thumb r-alloc ( u -- a )
	rsp w mov,

	\ allocate space
	tos rsp rsp sub,
	rsp tos mov,
	4 ## rsp sub,
	rsp 0@ w str,	\ save old rsp

	\ save new returning adress
	4 ## rsp sub,
	rsp 0@ u str,
	pc u mov,
	3 ## u add,	\ 2 to skip this insn and 1 for Thumb
	ret

	\ this is called on next return
	rsp ia! u ldm,
	rsp 0@ rsp ldr,
	u bx,
end-code

\ copy bytes from one address to another
code-thumb copy ( to from u -- )
	v0 v1 pop
	tos tos tst,
	__end eq? b,

	\ loop
	l: __copy

	\ transfer
	v0 0@ w ldrh,
	2 ## v0 add,
	v1 0@ w strh,
	2 ## v1 add,

	\ decrement and loop
	2 ## tos sub,	\ subs, actually
	\ if > 0 then continue
	__copy gt? b,

l: __end
	tos pop
	ret
end-code

\ erase bytes at an address
code-thumb erase ( a u -- )
	v0 pop
	w w eor,
	tos tos tst,

	\ if <= 0 then return
	__exit le? b,

	\ loop
	l: __erase

	\ erase
	v0 0@ w str,
	4 ## v0 add,

	\ decrement and loop
	4 ## tos sub,	\ subs, actually
	__erase gt? b,

	l: __exit
	tos pop
	ret
end-code

\ return the current scanline
icode-thumb scanline 4 ( -- n )
	tos push
	$40 ## tos mov,
	20 ## tos tos lsl,	\ REGISTERS
	tos 6 #( tos ldrh,
end-code