    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompExcessGibbsEnergySUBI.f90
    !> \brief   Compute the partial molar excess Gibbs energy of mixing of solution phase constituents in a
    !!          SUBI solution phase.
    !> \author  M.H.A. Piro
    !> \date    January 19, 2021
    !> \sa      CompExcessGibbsEnergy.f90
    !> \sa      CompExcessGibbsEnergyRKMP.f90
    !> \sa      CompExcessGibbsEnergyQKTO.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer      Description of change
    !   ----            ----------      ---------------------
    !   01/19/2021      M. Poschmann     Original code
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of mixing
    !! (dPartialExcessGibbs) of all constituents in a non-ideal solution phase designated as 'SUBI'
    !! (Ionic Liquid Model).
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] iSolnIndex    Absolute index of a solution phase
    !
    ! nSpeciesPhase             An integec vector representing the last index of a species in a particular
    !                            solution phase
    ! nParamPhase               An integer vector representing the number of parameters for a particular phase.
    ! nSublattice               An integer scalar representing the number of sublattices associated with this
    !                            particular phase (used for convenience).
    ! nSublatticePhase          An integer vector representing the number of sublattices for each charged phase.
    ! iSPI           An integer scalar representing the relative index of the charged phase.
    ! iParam                    An integer scalar representing the index number of a parameter.
    ! iPhaseSublattice          An integer vector representing the relative index of a charged phase corresponding
    !                            to each solution phase in the system.  Thus, it is equal to zero for a phase
    !                            that does not contain any sublattices.
    ! iRegularParam             An integer matrix representing the relative indices of species mixing for a
    !                            particular parmater.
    ! iFirst             An integer scalar representing the absolute index of the first species in a phase.
    ! iLast              An integer scalar representing the absolute index of the last species in a phase.
    ! dChemicalPotential        A double real vector representing the chemical potential for every species in the
    !                            system.
    ! dMolFraction              A double real vector representing hte mole fraction of all species in the system.
    ! dSiteFraction             A double real array representing the site fraction of each constituent on each
    !                            sublattice.  The first dimension corresponds to the charged phase index, the
    !                            second dimension corresponds to the sublattice index and the third dimension
    !                            corresponds to the constituent index.
    ! dExcessGibbsParam         A double real vector representing the molar excess Gibbs energy of mixing for
    !                            each subsystem.
    ! dPartialExcessGibbs       Partial molar excess Gibbs energy of mixing of species.
    ! dMolFraction              Current estimated mole fraction.
    ! cSolnPhaseType            A character vector representing the solution phase type.
    ! iConstituentSublattice    An integer array representing the constituent index for a particular sublattice
    !                            phase.  The first dimension refers to the relative phase index for charged phases,
    !                            the second dimension represents the sublattice index and the third dimension
    !                            corresponds to the relative component index (not absolute).
    ! iFirstParam               An integer scalar representing the constituent index of the first constituent
    !                            that is being mixed for a mixing parameter.
    ! iSeconParam               An integer scalar representing the constituent index of the second constituent
    !                            that is being mixed for a mixing parameter.
    ! iSubParam                 An integer scalar representing the sublattice index corresponding to the mixing
    !                            parameter.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompExcessGibbsEnergySUBI(iSolnIndex)

    USE ModuleThermo
    USE ModuleThermoIO
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, l, k1, l1, k2, l2, m, n, c, d, k, s
    integer :: iCi, iCj, iCk, iBi, iBj, iBk, iAi, iAj, iDi, iDj
    integer :: iSolnIndex, nSublattice, iSPI, iExponent
    integer :: iFirst, iLast, iExponentAdjust
    real(8) :: dSub1Total, dSub2Total, dydn
    real(8) :: dSum, p, q, kc1, kc2, lc1, lc2, cc1, gref, gideal, gexcess, natom, yva, dMol, dMolAtoms
    real(8), dimension(:), allocatable :: dgdc1, dgdc2, dMolDerivatives
    real(8) :: dPreFactor, v, f, chargeCi, chargeCj, chargeCk
    real(8) :: yCi, yCj, yCk, yAi, yAj, yBi, yBj, yBk, yDi, yDj, gex
    logical :: lEven

    ! Only proceed if the correct phase type is selected:
    IF_SUBL: if (cSolnPhaseType(iSolnIndex) == 'SUBI') then

        ! Define temporary variables for sake of convenience:
        iSPI = iPhaseSublattice(iSolnIndex)
        nSublattice     = nSublatticePhase(iSPI)
        iFirst          = nSpeciesPhase(iSolnIndex-1) + 1
        iLast           = nSpeciesPhase(iSolnIndex)

        if (allocated(dgdc1)) deallocate(dgdc1)
        if (allocated(dgdc2)) deallocate(dgdc2)
        if (allocated(dMolDerivatives)) deallocate(dMolDerivatives)
        allocate(dgdc1(nConstituentSublattice(iSPI,1)),dgdc2(nConstituentSublattice(iSPI,2)))
        allocate(dMolDerivatives(iLast - iFirst + 1))

        ! Initialize variables:
        dSiteFraction(iSPI,1:nSublattice,1:nMaxConstituentSys) = 0D0
        dChemicalPotential(iFirst:iLast)                       = 0D0
        dPartialExcessGibbs(iFirst:iLast)                      = 0D0
        dgdc1                                                  = 0D0
        dgdc2                                                  = 0D0
        dMolDerivatives                                        = 0D0

        ! Compute site fractions on first sublattice:
        do i = iFirst, iLast
            ! Relative component index:
            m = i - iFirst + 1
            c = iConstituentSublattice(iSPI,1,m)
            d = iConstituentSublattice(iSPI,2,m)

            if (cConstituentNameSUB(iSPI,2,d) == 'Va') then
                lc2 = 1D0
            else
                lc2 = -dSublatticeCharge(iSPI,2,d)
            end if
            if (c > 0) then
                dSiteFraction(iSPI,1,c) = dSiteFraction(iSPI,1,c) + dMolFraction(i) * lc2
            end if
        end do

        ! Correct first site fraction
        dSub1Total = 0D0
        do i = 1, nConstituentSublattice(iSPI,1)
            dSub1Total = dSub1Total + dSiteFraction(iSPI,1,i)
        end do
        do i = 1, nConstituentSublattice(iSPI,1)
            dSiteFraction(iSPI,1,i) = dSiteFraction(iSPI,1,i) / dSub1Total
        end do

        ! Compute Q
        q = 0D0
        do i = 1, nConstituentSublattice(iSPI,1)
            q = q + dSublatticeCharge(iSPI,1,i) * dSiteFraction(iSPI,1,i)
        end do

        ! Compute site fractions on second sublattice:
        do i = iFirst, iLast
            ! Relative component index:
            m = i - iFirst + 1
            c = iConstituentSublattice(iSPI,2,m)
            if (cConstituentNameSUB(iSPI,2,c) == 'Va') then
                ! Vacancy gets scaled by Q
                d = iConstituentSublattice(iSPI,1,m)
                dSiteFraction(iSPI,2,c) = dSiteFraction(iSPI,2,c) + dMolFraction(i) * dSublatticeCharge(iSPI,1,d) / q
            else if (dSublatticeCharge(iSPI,2,c) == 0D0) then
                ! Neutral counts as 1
                dSiteFraction(iSPI,2,c) = dSiteFraction(iSPI,2,c) + dMolFraction(i)
            else
                d = iConstituentSublattice(iSPI,1,m)
                dSiteFraction(iSPI,2,c) = dSiteFraction(iSPI,2,c) + dMolFraction(i) * dSublatticeCharge(iSPI,1,d)
            end if
        end do

        ! Correct second site fraction
        dSub2Total = 0D0
        yva = 0D0
        do i = 1, nConstituentSublattice(iSPI,2)
            dSub2Total = dSub2Total + dSiteFraction(iSPI,2,i)
        end do
        do i = 1, nConstituentSublattice(iSPI,2)
            dSiteFraction(iSPI,2,i) = dSiteFraction(iSPI,2,i) / dSub2Total
            ! find site fraction of vacancies
            if (cConstituentNameSUB(iSPI,2,i) == 'Va') yva = dSiteFraction(iSPI,2,i)
        end do

        ! Compute P
        p = 0D0
        do i = 1, nConstituentSublattice(iSPI,2)
            if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                ! Use Q as charge if this constituent is vacancy
                p = p + q * dSiteFraction(iSPI,2,i)
            else
                p = p - dSublatticeCharge(iSPI,2,i) * dSiteFraction(iSPI,2,i)
            end if
        end do

        ! Compute number of moles and its derivatives
        dMol = (p + (q * (1D0 - yva)))
        do j = iFirst, iLast
            ! Relative species index:
            n = j - iFirst + 1

            ! Store constituent indices:
            l1 = iConstituentSublattice(iSPI,1,n)
            l2 = iConstituentSublattice(iSPI,2,n)

            ! Allocating the correct constituent charges
            if (l1 > 0) lc1 = dSublatticeCharge(iSPI,1,l1)
            lc2 = -dSublatticeCharge(iSPI,2,l2)

            if (cConstituentNameSUB(iSPI,2,l2) == 'Va') then
                ! cation / vacancy
                dMolDerivatives(n) = (q-lc1)*(1D0+(p-q*yva)*yva/q)/(dSub1Total*dMol**2)
                dMolDerivatives(n) = dMolDerivatives(n) + (p-q*yva)*lc1/(dSub2Total*q*dMol**2)
            else if (dSublatticeCharge(iSPI,2,l2) == 0D0) then
                ! neutral
                dMolDerivatives(n) = (p-q*yva)/(dSub2Total*dMol**2)
            else
                ! cation / anion
                dMolDerivatives(n) = (q-lc1)*(1D0+(p-q*yva)*yva/q)*lc2/(dSub1Total*dMol**2)
                dMolDerivatives(n) = dMolDerivatives(n) + (p-q*yva-lc2)*lc1/(dSub2Total*dMol**2)
            end if
        end do

        ! Correct the mole fractions of phase components by the site fractions of the constituents
        dSum = 0D0
        LOOP_CorrectX: do i = iFirst, iLast
            dMolFraction(i) = 1D0
            m = i - iFirst + 1

            c = iConstituentSublattice(iSPI,2,m)
            d = iConstituentSublattice(iSPI,1,m)

            if (cConstituentNameSUB(iSPI,2,c) == 'Va') then
                dMolFraction(i) = dMolFraction(i) * dSiteFraction(iSPI,1,d)
                dMolFraction(i) = dMolFraction(i) * dSiteFraction(iSPI,2,c) * q
            else if (dSublatticeCharge(iSPI,2,c) == 0D0) then
                dMolFraction(i) = dMolFraction(i) * dSiteFraction(iSPI,2,c) * q
            else
                dMolFraction(i) = dMolFraction(i) * dSiteFraction(iSPI,1,d)
                dMolFraction(i) = dMolFraction(i) * dSiteFraction(iSPI,2,c)
            end if
            dSum = dSum + dMolFraction(i)
        end do LOOP_CorrectX

        ! Normalize mole fractions and compute number of mole atoms per mole (yes that makes sense, don't think about it)
        dMolAtoms = 0D0
        do i = iFirst, iLast

            dMolFraction(i)  = dMolFraction(i) / dSum

            m = i - iFirst + 1
            d = iConstituentSublattice(iSPI,1,m)
            c = iConstituentSublattice(iSPI,2,m)
            if ((cConstituentNameSUB(iSPI,2,c) == 'Va') .OR. &
                (dSublatticeCharge(iSPI,2,c) == 0D0)) then
                dMolAtoms = dMolAtoms + dMolFraction(i)
            else
                dMolAtoms = dMolAtoms + dMolFraction(i) * (dSublatticeCharge(iSPI,1,d) - dSublatticeCharge(iSPI,2,c))
            end if
        end do

        dStoichSublattice(iSPI,1) = p
        dStoichSublattice(iSPI,2) = q

        !---------------------------------------------------------------
        !             EXCESS TERMS - With Derived Excess Terms
        ! --------------------------------------------------------------
        gexcess = 0D0
        ! Loop through parameters:
        LOOP_Param: do l = nParamPhase(iSolnIndex-1) + 1, nParamPhase(iSolnIndex)
            ! Return control to the parent subroutine if there aren't any interaction parameters for this phase:
            if (nParamPhase(iSolnIndex) - nParamPhase(iSolnIndex-1) == 0) exit LOOP_Param

            ! Reinitialize temporary variable:
            dPreFactor = 1D0

            f = 0D0
            v = 0D0

            chargeCi = 0D0
            chargeCj = 0D0
            chargeCk = 0D0

            iAi = 0
            iAj = 0
            iBi = 0
            iBj = 0
            iBk = 0
            iCi = 0
            iCj = 0
            iCk = 0
            iDi = 0
            iDj = 0

            iExponentAdjust = 0

            yCi = 0D0
            yCj = 0D0
            yCk = 0D0
            yAi = 0D0
            yAj = 0D0
            yBi = 0D0
            yBj = 0D0
            yBk = 0D0
            yDi = 0D0
            yDj = 0D0

            gex = 0D0

            ! Store the number of constituents involved in this parameter:
            n = iRegularParam(l,1)

            ! Case 1: Determine the mixing parameter type: L_Ci,Cj:Ak
            if (iSUBIMixType(l) == 1) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)

                    ! Store the first and second site fractions:
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                        chargeCi = dSublatticeCharge(iSPI,s,c)

                    else if (k == 3) then
                        ! cation - Cj
                        yCj = dSiteFraction(iSPI,s,c)
                        iCj = c
                        chargeCj = dSublatticeCharge(iSPI,s,c)

                    else if (k == 4) then
                        ! anion - Ak
                        yAi =  dSiteFraction(iSPI,s,c)
                        iAi = c

                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Excess Gibbs energy equation for L_Ci,Cj:Ak case
                gex = dPreFactor * dExcessGibbsParam(l) * (yCi - yCj)**(iExponent)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                ! Avoiding a situation with 0^(-1)
                if ((yCi - yCj) /= 0) then

                    ! First sublattice - Cation:vacancy contributions
                    do i = 1, nConstituentSublattice(iSPI,1)

                        ! Derivative with respect to Ci
                        if (i == iCi) then
                            dgdc1(i) = dgdc1(i) + gex / yCi

                            dgdc1(i) = dgdc1(i) + gex * iExponent / (yCi - yCj)

                        ! Derivative with respect to Cj
                        else if (i == iCj) then
                            dgdc1(i) = dgdc1(i) + gex / yCj

                            dgdc1(i) = dgdc1(i) + gex * iExponent * (-1) / (yCi - yCj)

                        end if
                    end do
                end if

                ! Second sublattice - Cation:vacancy contributions
                do i = 1, nConstituentSublattice(iSPI,2)
                    if (i == iAi) then
                        dgdc2(i) = dgdc2(i) + gex / yAi

                    end if
                end do

            ! Case 2: Determine the mixing parameter type: L_Ci:Aj,Dk
            else if (iSUBIMixType(l) == 2) then
                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)

                    ! Establishing the site fractions for the L_Ci:Aj,Dk cases
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! anion - Aj
                        yAi = dSiteFraction(iSPI,s,c)
                        iAi = c
                    else if (k == 4) then
                        ! Dl - anion, vacancy or neutral
                        yDi = dSiteFraction(iSPI,s,c)
                        iDi = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Excess Gibbs energy equation for L_Ci:Aj,Dk case
                gex =  dPreFactor * dExcessGibbsParam(l) * (yAi - yDi)**(iExponent)
                ! Total Excess Gibbs
                gexcess = gexcess + gex

                ! Derived Excess Equations for Mixing Case 1: L_Ci:Aj,Dk
                ! Chemical potential with respect to the first sublattice
                do i = 1, nConstituentSublattice(iSPI,1)
                    if (i == iCi) then
                        dgdc1(i) = dgdc1(i) + gex / yCi
                    end if
                end do

                ! Avoiding a situation with 0^(-1)
                if ((yAi - yDi) /= 0D0) then
                    ! Chemical potential with respect to the second sublattice
                    do i = 1, nConstituentSublattice(iSPI,2)
                        if (i == iAi) then
                            ! cation / anion
                            dgdc2(i) = dgdc2(i) + gex / yAi
                            dgdc2(i) = dgdc2(i) + gex * iExponent / (yAi - yDi)
                        else if (i == iDi) then
                            ! Dl - anion, vacancy or neutral
                            dgdc2(i) = dgdc2(i) + gex / yDi
                            dgdc2(i) = dgdc2(i) + gex * iExponent * (-1) / (yAi - yDi)
                        end if
                    end do
                end if

            ! Case 3: Determine the mixing parameter type: L_Ci,Cj:Va
            else if (iSUBIMixType(l) == 3) then
                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Store the first and second site fractions:
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                        chargeCi = dSublatticeCharge(iSPI,s,c)
                        ! Compute prefactor term:
                        dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)
                    else if (k == 3) then
                        ! cation - Cj
                        yCj = dSiteFraction(iSPI,s,c)
                        iCj = c
                        chargeCj = dSublatticeCharge(iSPI,s,c)
                        ! Compute prefactor term:
                        dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)
                    else if (k == 4) then
                        ! Vacancy
                        yva = dSiteFraction(iSPI,s,c)
                        ! Compute prefactor term:
                        dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)**2
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Excess Gibbs energy equation for L_Ci,Cj:Va case
                gex = q * dPreFactor * dExcessGibbsParam(l) * (yCi - yCj)**(iExponent)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                ! Derived Excess Equations for Mixing Case 2: L_Ci,Cj:Va
                ! Avoiding a situation with 0^(-1)
                if ((yCi - yCj) /= 0) then
                    ! Chemical potential with respect to the first sublattice
                    do i = 1, nConstituentSublattice(iSPI,1)

                        ! Derivative with respect to Ci
                        if (i == iCi) then
                            dgdc1(i) = dgdc1(i) + gex / yCi
                            dgdc1(i) = dgdc1(i) + gex * chargeCi / q
                            dgdc1(i) = dgdc1(i) + gex * iExponent / (yCi - yCj)
                        ! Derivative with respect to Cj
                        else if (i == iCj) then
                            dgdc1(i) = dgdc1(i) + gex / yCj
                            dgdc1(i) = dgdc1(i) + gex * chargeCj / q
                            dgdc1(i) = dgdc1(i) + gex * iExponent * (-1) / (yCi - yCj)
                       else
                            !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                            ! Not yet tested
                            ! If there are additional cations that are not i or j
                            dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                        end if
                    end do
                end if

                ! Second sublattice - Cation:vacancy contributions
                do i = 1, nConstituentSublattice(iSPI,2)
                    if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                        dgdc2(i) = dgdc2(i) + 2 * gex / yva
                    end if
                end do

            ! Case 4: Determine the mixing parameter type: L_Ci:Va,Bj
            else if (iSUBIMixType(l) == 4) then
                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)

                    ! Store the first and second site fractions:
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                        chargeCi = dSublatticeCharge(iSPI,s,c)
                    else if (k == 3) then
                        ! vacancy - Va
                        yva = dSiteFraction(iSPI,s,c)
                    else if (k == 4) then
                        ! nuetral - Bj
                        yBi = dSiteFraction(iSPI,s,c)
                        iBi = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Excess Gibbs energy equation for L_Ci:Va,Bj case
                gex = q * dPreFactor * dExcessGibbsParam(l) * (yCi * yva - yBi)**(iExponent)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                ! Avoiding a situation with 0^(-1)
                if ((yCi * yva - yBi) /= 0) then

                    ! First sublattice
                    do i = 1, nConstituentSublattice(iSPI,1)
                        if (i == iCi) then
                            ! cation - Ci
                            dgdc1(i) = dgdc1(i) + gex / yCi
                            dgdc1(i) = dgdc1(i) + gex * chargeCi / q
                            dgdc1(i) = dgdc1(i) + gex * iExponent * yva / (yCi * yva - yBi)
                        else
                            !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
                            ! Not yet tested
                            ! If there are additional cations that are not i
                            dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                        end if
                    end do

                    ! Second sublattice
                    do i = 1, nConstituentSublattice(iSPI,2)
                        if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                            ! vacancy contributions
                            dgdc2(i) = dgdc2(i) + gex / yva
                            dgdc2(i) = dgdc2(i) + gex * iExponent * yCi / (yCi * yva - yBi)
                        else if (i == iBi) then
                            ! neutral contributions
                            dgdc2(i) = dgdc2(i) + gex / yBi
                            dgdc2(i) = dgdc2(i) + gex * iExponent * (-1) / (yCi * yva - yBi)
                        end if
                    end do
                end if

            ! Begining of ternary mixing cases
            ! Case 5: Determine the mixing parameter type: L_Ci:Bj,Bk
            else if (iSUBIMixType(l) == 5) then
                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Store the first and second site fractions:
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                        chargeCi = dSublatticeCharge(iSPI,s,c)
                    else if (k == 3) then
                        ! nuetral - Bj
                        yBi = dSiteFraction(iSPI,s,c)
                        iBi = c
                        ! Compute prefactor term:
                        dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)
                    else if (k == 4) then
                        ! nuetral - Bk
                        yBj = dSiteFraction(iSPI,s,c)
                        iBj = c
                        ! Compute prefactor term:
                        dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Excess Gibbs energy equation for L_Ci:Bj,Bk case
                gex = q * dPreFactor * dExcessGibbsParam(l) * (yCi*yBi - yBj)**(iExponent)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                ! Derived Excess Equations for Mixing Case 1: L_Ci:Aj,Dk
                ! Chemical potential with respect to the first sublattice
                do i = 1, nConstituentSublattice(iSPI,1)
                    dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                end do

                ! Avoiding a situation with 0^(-1)
                if ((yBi - yBj) /= 0D0) then
                    do i = 1, nConstituentSublattice(iSPI,2)
                        if (i == iBi) then
                            ! cation / anion
                            dgdc2(i) = dgdc2(i) + gex / yBi
                            dgdc2(i) = dgdc2(i) + gex * iExponent / (yBi - yBj)
                        else if (i == iBj) then
                            ! Dl - anion, vacancy or neutral
                            dgdc2(i) = dgdc2(i) + gex / yBj
                            dgdc2(i) = dgdc2(i) + gex * iExponent * (-1) / (yBi - yBj)
                        end if
                    end do
                end if

            ! Case 6: Determine the mixing parameter type: L_Ci,Cj,Ck:Al
            else if (iSUBIMixType(l) == 6) then
                print *, 'Unrecognized excess mixing term in SUBI phase. Case #6. ', cSolnPhaseName(iSolnIndex)
                INFOThermo = 44
                return
                ! ! Loop through constituents associated with this parameter:
                ! do k = 2, n + 1
                !     ! Determine constituent and sublattice indices:
                !     c = MOD(iRegularParam(l,k), 10000)
                !     s = iRegularParam(l,k) - c
                !     s = s / 10000
                !
                !     ! Compute prefactor term:
                !     dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)
                !
                !     if (k == 2) then
                !         ! Cation - Ci
                !         yCi = dSiteFraction(iSPI,s,c)
                !         iCi = c
                !     else if (k == 3) then
                !         ! Cation - Cj
                !         yCj = dSiteFraction(iSPI,s,c)
                !         iCj = c
                !     else if (k == 4) then
                !         ! Cation - Ck
                !         yCk = dSiteFraction(iSPI,s,c)
                !         iCk = c
                !     else if (k == 5) then
                !         ! Anion - Al
                !         yAi = dSiteFraction(iSPI,s,c)
                !         iAi = c
                !     end if
                ! end do
                !
                ! ! Multiply prefactor term by excess Gibbs energy parameter:
                ! iExponent = iRegularParam(l,n+2)
                ! ! Calculate f and v
                ! f = (1D0 - yCi - yCj - yCk)/3D0
                ! if (iRegularParam(l,n+2) == 0) then
                !     v = yCi + f
                ! else if (iRegularParam(l,n+2) == 1) then
                !     v = yCj + f
                ! else if (iRegularParam(l,n+2) == 2) then
                !     v = yCk + f
                ! end if
                !
                ! ! Excess Gibbs energy equation for L_Ci,Cj,Ck:Al case
                ! gex = dPreFactor * v * dExcessGibbsParam(l)
                ! ! Total Excess Gibbs Energy
                ! gexcess = gexcess + gex
                !
                ! do i = 1, nConstituentSublattice(iSPI, 1)
                !     ! Derivative with respect to C
                !     if (i == iCi) then
                !         ! prefactor part
                !         dgdc1(i) = dgdc1(i) + gex / yCi
                !         ! f part
                !         dgdc1(i) = dgdc1(i) - gex / (3D0 * v)
                !         ! other v part
                !         if (iRegularParam(l,n+2) == 0) dgdc1(i) = dgdc1(i) + gex / v
                !     ! Derivative with respect to Cj
                !     else if (i == iCj) then
                !         ! prefactor part
                !         dgdc1(i) = dgdc1(i) + gex / yCj
                !         ! f part
                !         dgdc1(i) = dgdc1(i) - gex / (3D0 * v)
                !         ! other v part
                !         if (iRegularParam(l,n+2) == 1) dgdc1(i) = dgdc1(i) + gex / v
                !     else if (i == iCk) then
                !         ! prefactor part
                !         dgdc1(i) = dgdc1(i) + gex / yCk
                !         ! f part
                !         dgdc1(i) = dgdc1(i) - gex / (3D0 * v)
                !         ! other v part
                !         if (iRegularParam(l,n+2) == 2) dgdc1(i) = dgdc1(i) + gex / v
                !     end if
                ! end do
                !
                ! do i = 1, nConstituentSublattice(iSPI,2)
                !   ! Derivative with respect to Bk
                !     if (i == iAi) then
                !         ! prefactor part
                !         dgdc2(i) = dgdc2(i) + gex / yAi
                !     end if
                ! end do

            ! Case 7: Determine the mixing parameter type: L_Ci:Aj,Dk,Dl
            else if (iSUBIMixType(l) == 7) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)

                    if (k == 2) then
                        ! Cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! Anion - Aj
                        yAi = dSiteFraction(iSPI,s,c)
                        iAi = c
                    else if (k == 4) then
                        ! Dk
                        yDi = dSiteFraction(iSPI,s,c)
                        iDi = c
                    else if (k == 5) then
                        ! Dl
                        yDj = dSiteFraction(iSPI,s,c)
                        iDj = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Calculate f and v
                f = (1D0 - yAi - yDi - yDj)/3D0
                if (iRegularParam(l,n+2) == 0) then
                    v = yAi + f
                else if (iRegularParam(l,n+2) == 1) then
                    v = yDi + f
                else if (iRegularParam(l,n+2) == 2) then
                    v = yDj + f
                end if

                ! Excess Gibbs energy equation for L_Ci:Aj,Dk,Dl case
                gex = dPreFactor * v * dExcessGibbsParam(l)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex
                ! First Sublattice
                do i = 1, nConstituentSublattice(iSPI, 1)
                    ! Derivative with respect to C
                    if (i == iCi) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCi
                    end if
                end do

                ! Second Sublattice
                do i = 1, nConstituentSublattice(iSPI,2)
                  ! Derivative with respect to Bk
                    if (i == iAi) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yAi
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc2(i) = dgdc2(i) + gex / v
                    else if (i == iDi) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yDi
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 1) dgdc2(i) = dgdc2(i) + gex / v
                    else if (i == iDj) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yDj
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 2) dgdc2(i) = dgdc2(i) + gex / v
                    end if
                end do

            ! Case 8: Determine the mixing parameter type: L_Ci,Cj,Ck:Va
            else if (iSUBIMixType(l) == 8) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    if (k == 2) then
                        ! Cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! Cation - Cj
                        yCj = dSiteFraction(iSPI,s,c)
                        iCj = c
                    else if (k == 4) then
                        ! Cation - Ck
                        yCk = dSiteFraction(iSPI,s,c)
                        iCk = c
                    end if
                end do
                ! Compute prefactor term:
                dPreFactor = yCi * yCj * yCk * yva**3
                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                ! Calculate f and v
                f = (1D0 - yva * yCi - yva * yCj - yva * yCk)/3D0
                if (iRegularParam(l,n+2) == 0) then
                    v = yva * yCi + f
                else if (iRegularParam(l,n+2) == 1) then
                    v = yva * yCj + f
                else if (iRegularParam(l,n+2) == 2) then
                    v = yva * yCk + f
                end if

                ! Excess Gibbs energy equation for L_Ci,Cj,Ck:Al case
                gex = q * dPreFactor * v * dExcessGibbsParam(l)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                do i = 1, nConstituentSublattice(iSPI, 1)
                    ! Q part:
                    dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                    ! Derivative with respect to C
                    if (i == iCi) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCi
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc1(i) = dgdc1(i) + yva * gex / v
                    ! Derivative with respect to Cj
                    else if (i == iCj) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCj
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 1) dgdc1(i) = dgdc1(i) + yva * gex / v
                    else if (i == iCk) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCk
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 2) dgdc1(i) = dgdc1(i) + yva * gex / v
                    end if
                end do

                do i = 1, nConstituentSublattice(iSPI,2)
                    ! Derivative with respect to Va
                    if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex * 3D0 / yva
                        ! f part
                        dgdc2(i) = dgdc2(i) - (yCi + yCj + yCk) * gex / (3D0 * v)
                        ! other v parts
                        if (iRegularParam(l,n+2) == 0) dgdc2(i) = dgdc2(i) + yCi * gex / v
                        if (iRegularParam(l,n+2) == 1) dgdc2(i) = dgdc2(i) + yCj * gex / v
                        if (iRegularParam(l,n+2) == 2) dgdc2(i) = dgdc2(i) + yCk * gex / v
                    end if
                end do

            ! Case 9: Determine the mixing parameter type: L_Ci:Va,Bj,Bk
            else if (iSUBIMixType(l) == 9) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    if (k == 2) then
                        ! Cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! vacancy
                        yva = dSiteFraction(iSPI,s,c)
                    else if (k == 4) then
                        ! neutral - Bi
                        yBi = dSiteFraction(iSPI,s,c)
                        iBi = c
                    else if (k == 5) then
                        ! Neutral - Bj
                        yBj = dSiteFraction(iSPI,s,c)
                        iBj = c
                    end if
                end do

                ! Compute prefactor term:
                dPreFactor = yCi * yva * yBi * yBj
                ! Calculate f and v
                f = (1D0 - yCi * yva - yBi - yBj)/3D0
                if (iRegularParam(l,n+2) == 0) then
                    v = yCi * yva + f
                else if (iRegularParam(l,n+2) == 1) then
                    v = yBi + f
                else if (iRegularParam(l,n+2) == 2) then
                    v = yBj + f
                end if
                ! Excess Gibbs energy equation for L_Ci:Va,Bj,Bk case
                gex = q * dPreFactor * v * dExcessGibbsParam(l)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                do i = 1, nConstituentSublattice(iSPI, 1)
                    ! Q part:
                    dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                    ! Derivative with respect to Ci
                    if (i == iCi) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCi
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc1(i) = dgdc1(i) + yva * gex / v
                    end if
                end do

                do i = 1, nConstituentSublattice(iSPI,2)
                    ! Derivative with respect to Bk
                    if (i == iBi) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yBi
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 1) dgdc2(i) = dgdc2(i) + gex / v
                    ! Derivative with respect to Bl
                    else if (i == iBj) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yBj
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 2) dgdc2(i) = dgdc2(i) + gex / v
                    ! Derivative with respect to Va
                    else if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yva
                        ! f part
                        dgdc2(i) = dgdc2(i) - yCi * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc2(i) = dgdc2(i) + yCi * gex / v
                    end if
                end do

            ! Case 10: Determine the mixing parameter type: L_Ci:Bj,Bk,Bl
          else if (iSUBIMixType(l) == 10) then
              print *, 'Unrecognized excess mixing term in SUBI phase. Case #6. ', cSolnPhaseName(iSolnIndex)
              INFOThermo = 44
              return

              ! ! Loop through constituents associated with this parameter:
              ! do k = 2, n + 1
              !     ! Determine constituent and sublattice indices:
              !     c = MOD(iRegularParam(l,k), 10000)
              !     s = iRegularParam(l,k) - c
              !     s = s / 10000
              !
              !     if (k == 3) then
              !         ! neutral - Bj
              !         yBi = dSiteFraction(iSPI,s,c)
              !         iBi = c
              !     else if (k == 4) then
              !         ! neutral - Bk
              !         yBj = dSiteFraction(iSPI,s,c)
              !         iBj = c
              !     else if (k == 5) then
              !         ! neutral - Bl
              !         yBk = dSiteFraction(iSPI,s,c)
              !         iBk = c
              !     end if
              ! end do
              !
              ! ! Compute prefactor term:
              ! dPreFactor = yBi * yBj * yBk
              ! ! Calculate f and v
              ! f = (1D0 - yBi - yBj - yBk)/3D0
              ! if (iRegularParam(l,n+2) == 0) then
              !     v = yBi + f
              ! else if (iRegularParam(l,n+2) == 1) then
              !     v = yBj + f
              ! else if (iRegularParam(l,n+2) == 2) then
              !     v = yBk + f
              ! end if
              ! ! Excess Gibbs energy equation for L_Ci:Bj,Bk,Bl case
              ! gex = q * dPreFactor * v * dExcessGibbsParam(l)
              ! ! Total Excess Gibbs Energy
              ! gexcess = gexcess + gex
              !
              ! do i = 1, nConstituentSublattice(iSPI, 1)
              !     ! Q part:
              !     dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
              ! end do
              !
              ! do i = 1, nConstituentSublattice(iSPI,2)
              !     ! Derivative with respect to Bk
              !     if (i == iBi) then
              !         ! prefactor part
              !         dgdc2(i) = dgdc2(i) + gex / yBi
              !         ! f part
              !         dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
              !         ! other v part
              !         if (iRegularParam(l,n+2) == 0) dgdc2(i) = dgdc2(i) + gex / v
              !     ! Derivative with respect to Bl
              !     else if (i == iBj) then
              !         ! prefactor part
              !         dgdc2(i) = dgdc2(i) + gex / yBj
              !         ! f part
              !         dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
              !         ! other v part
              !         if (iRegularParam(l,n+2) == 1) dgdc2(i) = dgdc2(i) + gex / v
              !     ! Derivative with respect to Va
              !     else if (i == iBk) then
              !         ! prefactor part
              !         dgdc2(i) = dgdc2(i) + gex / yBk
              !         ! f part
              !         dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
              !         ! other v part
              !         if (iRegularParam(l,n+2) == 2) dgdc2(i) = dgdc2(i) + gex / v
              !     end if
              ! end do

            ! Case 11: Determine the mixing parameter type: L_Ci,Cj:Ak,Dl
            else if (iSUBIMixType(l) == 11) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iSPI,s,c)

                    ! Store the first and second site fractions:
                    if (k == 2) then
                        ! cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! cation - Cj
                        yCj = dSiteFraction(iSPI,s,c)
                        iCj = c
                    else if (k == 4) then
                        ! anion - Ak
                        yAi = dSiteFraction(iSPI,s,c)
                        iAi = c
                    else if (k == 5) then
                        ! Dl
                        yDi = dSiteFraction(iSPI,s,c)
                        iDi = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)

                ! Accounting for odd/even exponentials
                iExponentAdjust = iExponent

                if (MOD(iExponent,2) == 0) then
                    lEven = .TRUE.
                else
                    lEven = .FALSE.
                    iExponentAdjust = iExponentAdjust + 1
                end if

                iExponentAdjust = iExponentAdjust / 2

                ! Excess Gibbs energy equation for L_Ci,Cj:Ak,Dl case
                ! Dealing with the reciprocals
                ! Part 1 of equation:
                if (lEven) then
                    gex = dPreFactor * dExcessGibbsParam(l) * (yCi - yCj)**(iExponentAdjust)
                end if
                ! Part 2 of equation:
                if (.NOT. lEven) then
                    gex = dPreFactor * dExcessGibbsParam(l) * (yAi - yDi)**(iExponentAdjust)
                end if

                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                ! Avoiding a situation with 0^(-1)
                if ((yCi - yCj) /= 0) then
                    do i = 1, nConstituentSublattice(iSPI,1)
                        ! Derivative with respect to Ci
                        if (i == iCi) then
                            dgdc1(i) = dgdc1(i) + gex / yCi
                            ! Dealing with the reciprocals
                            if ((iExponent > 0) .AND. (lEven)) then
                                dgdc1(i) = dgdc1(i) +  gex * iExponentAdjust / (yCi - yCj)
                            end if

                        ! Derivative with respect to Cj
                        else if (i == iCj) then
                            dgdc1(i) = dgdc1(i) + gex / yCj
                            ! Dealing with the reciprocals
                            if ((iExponent > 0) .AND. (lEven)) then
                                dgdc1(i) = dgdc1(i) + gex * iExponentAdjust * (-1) / (yCi - yCj)
                            end if
                        end if
                    end do
                end if

                ! Avoiding a situation with 0^(-1)
                if ((yAi - yDi) /= 0) then

                    ! Chemical potential with respect to the second sublattice
                    do i = 1, nConstituentSublattice(iSPI,2)
                        !! When Dl = Al or Bl - Cases untested... %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                        if (i == iAi) then
                            ! anion - Ak
                            dgdc2(i) = dgdc2(i) + gex / yAi
                            ! Dealing with the reciprocals
                            if (.NOT. lEven) then
                                dgdc2(i) = dgdc2(i) + gex * iExponentAdjust / (yAi - yDi)
                            end if

                        else if (i == iDi) then
                            ! Dl
                            dgdc2(i) = dgdc2(i) + gex / yDi
                            ! Dealing with the reciprocals
                            if (.NOT. lEven) then
                                dgdc2(i) = dgdc2(i) + gex * iExponentAdjust * (-1) / (yAi - yDi)
                            end if
                        end if
                    end do
                end if

            ! Case 12: Determine the mixing parameter type: L_Ci,Cj:Va,Bk
            else if (iSUBIMixType(l) == 12) then

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    if (k == 2) then
                        ! Cation - Ci
                        yCi = dSiteFraction(iSPI,s,c)
                        iCi = c
                    else if (k == 3) then
                        ! Cation - Cj
                        yCj = dSiteFraction(iSPI,s,c)
                        iCj = c
                    else if (k == 4) then
                        ! Vacancy
                        yva = dSiteFraction(iSPI,s,c)
                    else if (k == 5) then
                        ! Neutral - Bk
                        yBi = dSiteFraction(iSPI,s,c)
                        iBi = c
                    end if
                end do

                ! Compute prefactor term:
                dPreFactor = yCi * yCj * yBi * yva**2
                ! Calculate f and v
                f = (1D0 - yCi * yva - yCj * yva - yBi)/3D0
                if (iRegularParam(l,n+2) == 0) then
                    v = yCi * yva + f
                else if (iRegularParam(l,n+2) == 1) then
                    v = yCj * yva + f
                else if (iRegularParam(l,n+2) == 2) then
                    v = yBi + f
                end if
                ! Excess Gibbs energy equation for L_Ci,Cj:Va,Bk case
                gex = q * dPreFactor * v * dExcessGibbsParam(l)
                ! Total Excess Gibbs Energy
                gexcess = gexcess + gex

                do i = 1, nConstituentSublattice(iSPI, 1)
                    ! Q part:
                    dgdc1(i) = dgdc1(i) + gex * dSublatticeCharge(iSPI,1,i) / q
                    ! Derivative with respect to C
                    if (i == iCi) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCi
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc1(i) = dgdc1(i) + yva * gex / v
                    ! Derivative with respect to Cj
                    else if (i == iCj) then
                        ! prefactor part
                        dgdc1(i) = dgdc1(i) + gex / yCj
                        ! f part
                        dgdc1(i) = dgdc1(i) - yva * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 1) dgdc1(i) = dgdc1(i) + yva * gex / v
                    end if
                end do

                do i = 1, nConstituentSublattice(iSPI,2)
                    ! Derivative with respect to Bk
                    if (i == iBi) then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex / yBi
                        ! f part
                        dgdc2(i) = dgdc2(i) - gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 2) dgdc2(i) = dgdc2(i) + gex / v
                    ! Derivative with respect to Va
                    else if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                        ! prefactor part
                        dgdc2(i) = dgdc2(i) + gex * 2 / yva
                        ! f part
                        dgdc2(i) = dgdc2(i) - (yCi + yCj) * gex / (3D0 * v)
                        ! other v part
                        if (iRegularParam(l,n+2) == 0) dgdc2(i) = dgdc2(i) + yCi * gex / v
                        if (iRegularParam(l,n+2) == 1) dgdc2(i) = dgdc2(i) + yCj * gex / v
                    end if
                end do
            else
                print *, 'Unrecognized excess mixing term in SUBI phase ', cSolnPhaseName(iSolnIndex)
                INFOThermo = 36
                return
            end if
        end do LOOP_Param

        ! REFERENCE GIBBS ENERGY AND IDEAL MIXING
        ! ---------------------------------------
        gref = 0D0
        do j = iFirst, iLast
            ! Relative species index:
            n = j - iFirst + 1

            ! Store constituent indices:
            l1 = iConstituentSublattice(iSPI,1,n)
            l2 = iConstituentSublattice(iSPI,2,n)

            if (cConstituentNameSUB(iSPI,2,l2) == 'Va') then
                ! cation / vacancy
                gref = gref + q * dSiteFraction(iSPI,1,l1) * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
            else if (dSublatticeCharge(iSPI,2,l2) == 0D0) then
                ! neutral
                gref = gref + q * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
            else
                ! cation / anion
                gref = gref + dSiteFraction(iSPI,1,l1) * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
            end if
        end do

        gideal = 0D0
        do i = 1, nConstituentSublattice(iSPI,1)
            gideal = gideal + p * dSiteFraction(iSPI,1,i) * DLOG(dSiteFraction(iSPI,1,i))
        end do

        do i = 1, nConstituentSublattice(iSPI,2)
            gideal = gideal + q * dSiteFraction(iSPI,2,i) * DLOG(dSiteFraction(iSPI,2,i))
        end do

        ! For Sublattice Number 1
        do i = 1, nConstituentSublattice(iSPI,1)
            lc1 = dSublatticeCharge(iSPI,1,i)
            ! Reference
            do j = iFirst, iLast
                ! Relative species index:
                n = j - iFirst + 1
                ! Store constituent indices:
                l1 = iConstituentSublattice(iSPI,1,n)
                l2 = iConstituentSublattice(iSPI,2,n)

                if (cConstituentNameSUB(iSPI,2,l2) == 'Va') then
                    ! cation / vacancy
                    if (i == l1) dgdc1(i) = dgdc1(i) + q * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
                    dgdc1(i) = dgdc1(i) + lc1 * dSiteFraction(iSPI,1,l1) * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
                else if (dSublatticeCharge(iSPI,2,l2) == 0D0) then
                    ! neutral
                    dgdc1(i) = dgdc1(i) + lc1 * dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
                else
                    ! cation / anion
                    if (i == l1) dgdc1(i) = dgdc1(i) + dSiteFraction(iSPI,2,l2) * dStdGibbsEnergy(j)
                end if
            end do

            ! Entropy
            dgdc1(i) = dgdc1(i) + (1 + DLOG(dSiteFraction(iSPI,1,i))) * p
            do j = 1, nConstituentSublattice(iSPI,1)
                dgdc1(i) = dgdc1(i) + dSublatticeCharge(iSPI,1,i) * yva &
                                    * dSiteFraction(iSPI,1,j)*DLOG(dSiteFraction(iSPI,1,j))
            end do
            do j = 1, nConstituentSublattice(iSPI,2)
                dgdc1(i) = dgdc1(i) + dSublatticeCharge(iSPI,1,i) * dSiteFraction(iSPI,2,j) * DLOG(dSiteFraction(iSPI,2,j))
            end do
        end do

        ! For Sublattice Number 2
        do i = 1, nConstituentSublattice(iSPI,2)
            do j = iFirst, iLast
                ! Relative species index:
                n = j - iFirst + 1

                ! Store constituent indices:
                l1 = iConstituentSublattice(iSPI,1,n)
                l2 = iConstituentSublattice(iSPI,2,n)

                if (cConstituentNameSUB(iSPI,2,l2) == 'Va') then
                    ! cation / vacancy
                    if (i == l2) dgdc2(i) = dgdc2(i) + q * dSiteFraction(iSPI,1,l1) * dStdGibbsEnergy(j)
                else if (dSublatticeCharge(iSPI,2,l2) == 0D0) then
                    ! neutral
                    if (i == l2) dgdc2(i) = dgdc2(i) + q * dStdGibbsEnergy(j)
                else
                    ! cation / anion
                    if (i == l2) dgdc2(i) = dgdc2(i) + dSiteFraction(iSPI,1,l1) * dStdGibbsEnergy(j)
                end if
            end do
            ! Entropy
            dgdc2(i) = dgdc2(i) + (1 + DLOG(dSiteFraction(iSPI,2,i))) * q
            do j = 1, nConstituentSublattice(iSPI,1)
                if (cConstituentNameSUB(iSPI,2,i) == 'Va') then
                    ! cation / vacancy
                    dgdc2(i) = dgdc2(i) + q * dSiteFraction(iSPI,1,j) * DLOG(dSiteFraction(iSPI,1,j))
                else if (dSublatticeCharge(iSPI,2,i) == 0D0) then
                    ! neutral
                else
                    ! cation / anion
                    dgdc2(i) = dgdc2(i) + (-dSublatticeCharge(iSPI,2,i)) * dSiteFraction(iSPI,1,j) * DLOG(dSiteFraction(iSPI,1,j))
                end if
            end do
        end do

        cc1 = 0D0

        ! Compute the chemical potential for each phase component assuming ideal mixing:
        LOOP_Ideal: do i = iFirst, iLast
            ! Relative species index:
            m = i - iFirst + 1
            k1 = iConstituentSublattice(iSPI,1,m)
            k2 = iConstituentSublattice(iSPI,2,m)

            kc1 = 1D0
            ! cation / vacancy
            if (cConstituentNameSUB(iSPI,2,k2) == 'Va') then
                kc2 = 1D0
                cc1 = dSublatticeCharge(iSPI,1,k1)
                natom = 1D0 / dMol + dMolDerivatives(m) * dMolAtoms
            ! neutral
            else if (dSublatticeCharge(iSPI,2,k2) == 0D0) then
                kc2 = 1D0
                cc1 = 1D0
                natom = 1D0 / dMol + dMolDerivatives(m) * dMolAtoms
            ! cation / anion
            else
                if (k1 > 0) kc1 = dSublatticeCharge(iSPI,1,k1)
                kc2 = -dSublatticeCharge(iSPI,2,k2)
                cc1 = dSublatticeCharge(iSPI,1,k1)
                natom = (kc1 + kc2) / dMol + dMolDerivatives(m) * dMolAtoms
            end if

            dChemicalPotential(i) = (gref + gideal + gexcess) * natom

            do j = 1, nConstituentSublattice(iSPI,1)
                ! cation / (anion or vacancy)
                if (k1 > 0) then
                    dydn = -kc2 * dSiteFraction(iSPI,1,j) / dSub1Total
                    if (j == k1) dydn = dydn + kc2 / dSub1Total
                    dChemicalPotential(i) = dChemicalPotential(i) + dydn * dgdc1(j) * dMolAtoms / dMol
                end if
            end do

            do j = 1, nConstituentSublattice(iSPI,2)
                ! cation / vacancy
                if (cConstituentNameSUB(iSPI,2,k2) == 'Va') then
                    dydn = -dSiteFraction(iSPI,2,j)*(dSub1Total*cc1+(q-cc1)*dSub2Total*yva)/(dSub1Total*dSub2Total*q)
                    if (cConstituentNameSUB(iSPI,2,j) == 'Va') then
                        ! vacancy
                        dydn = dydn + (dSub1Total*cc1+(q-cc1)*dSub2Total*yva)/(dSub1Total*dSub2Total*q)
                    else
                        ! neutral or anion
                    end if
                ! neutral
                else if (dSublatticeCharge(iSPI,2,k2) == 0D0) then
                    dydn = -dSiteFraction(iSPI,2,j) / dSub2Total
                    if (cConstituentNameSUB(iSPI,2,j) == 'Va') then
                        ! vacancy
                    else
                        ! neutral or anion
                        if (j == k2) dydn = dydn + 1 / dSub2Total
                    end if
                ! cation / anion
                else
                    dydn = -dSiteFraction(iSPI,2,j) * (cc1 / dSub2Total + kc2*yva*(q-cc1)/(dSub1Total*q))
                    if (cConstituentNameSUB(iSPI,2,j) == 'Va') then
                        dydn = dydn + dSiteFraction(iSPI,2,j) * kc2*(q-cc1)/(dSub1Total*q)
                    else if (dSublatticeCharge(iSPI,2,j) == 0D0) then
                        ! neutral
                    else
                        ! cation / anion
                        if (j == k2) dydn = dydn + cc1 / dSub2Total
                    end if
                end if
                dChemicalPotential(i) = dChemicalPotential(i) + dydn * dgdc2(j) * dMolAtoms / dMol
            end do
        end do LOOP_Ideal

        deallocate(dgdc1,dgdc2)
        deallocate(dMolDerivatives)
    end if IF_SUBL

    return

end subroutine CompExcessGibbsEnergySUBI


!! Choose one.
# define PP_GAUSS_NODES
!# define PP_GAUSS_LOBATTO_NODES

module kernel_utils_mod

use globals_mod
use equations_mod, only: N_VARS

private

public :: kernel_utils_init
public :: interpolate2visual

!! -------------------------------------------------------------------------- !!
!! nodes within reference element [-1,1]

real(dp), save, public :: refnodes(N_NODES)
real(dp), save, public :: refweights(N_NODES)
real(dp), save, public :: refweights2D(N_NODES,N_NODES)

!! -------------------------------------------------------------------------- !!
!! prolongate to boundaries

real(dp), save, public :: toBoundaryVecM(N_NODES)
real(dp), save, public :: toBoundaryVecP(N_NODES)

!! ------------------------------------------------------------------------- !!
!! Weak-Form Standard DG operators (on Legendre-Gauss nodes)

real(dp), save, public :: diffMat(N_NODES,N_NODES)
real(dp), save, public :: diffTam(N_NODES,N_NODES)

real(dp), save, public :: surfMat(N_NODES,N_NODES)
real(dp), save, public :: surfTam(N_NODES,N_NODES)

!! ------------------------------------------------------------------------- !!
!! Visualization operator

real(dp), save :: visuMat(N_NODES,N_NODES)
real(dp), save :: visuTam(N_NODES,N_NODES)

contains

!! ========================================================================== !!
!! Routines regarding Lagrange polynomials as well as quadrature points generation

pure function lagrange_polynomial(N, nodes, j, x) result(lp)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    integer, intent(in)     :: j
    real(dp), intent(in)    :: x

    real(dp)                :: lp

    integer :: i

    lp = 1.0

    if (abs(x-nodes(j)) < 10*TOL) return !! Kronecker property

    do i = 1,N
        if (i == j) cycle
        lp = lp * (x - nodes(i))/(nodes(j) - nodes(i))
    end do

end function

pure function lagrange_basis(N, nodes, x) result(lp)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: x

    real(dp)                :: lp(N)
    integer :: i

    !! Kronecker property
    if (any(abs(x-nodes) < 10*TOL)) then
        lp = merge(1.0,0.0,abs(x-nodes) < 10*TOL)
        return
    end if

    forall (i = 1:N) lp(i) = Lagrange_Polynomial(N, nodes, i, x)

end function

pure subroutine lagrange_VanderMonde_Matrix(N, M, xs, ys, mat)

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: xs(N), ys(M)
    real(dp), intent(out)   :: mat(M,N)

    integer :: i

    do i = 1,M
        mat(i,:) = Lagrange_Basis(N, xs, ys(i))
    end do

end subroutine

subroutine barycentric_weights(N,nodes,weights)

    integer,intent(in)      :: N
    real(dp),intent(in)     :: nodes(N)
    real(dp),intent(out)    :: weights(N)

    integer :: i,j

    weights = 1.0_dp

    do i = 2,N
        do j = 1,i-1
            weights(j) = weights(j)*(nodes(j) - nodes(i))
            weights(i) = weights(i)*(nodes(i) - nodes(j))
        end do
    end do

    weights = 1.0_dp/weights

end subroutine

subroutine lagrange_diff_matrix(N,nodes,diffMat)

    integer,intent(in)      :: N !! number of nodes
    real(dp),intent(in)     :: nodes(N)
    real(dp),intent(out)    :: diffMat(N,N)

    integer     :: i,j
    real(dp)    :: bweights(N)

    call barycentric_weights(N,nodes,bweights)

    diffMat = 0.0_dp

    do j = 1,N
        do i = 1,N
            if (i.ne.j) then
                diffMat(i,j) = bweights(j)/(bweights(i)*(nodes(i) - nodes(j)))
                diffMat(i,i) = diffMat(i,i) - diffMat(i,j)
            end if
        end do
    end do

end subroutine

# if defined(PP_GAUSS_NODES)
pure subroutine Legendre_polynomial_and_derivative(p,x,L,Lder)

    integer,intent(in)      :: p !! polynomial order
    real(dp),intent(in)     :: x
    real(dp),intent(out)    :: L
    real(dp),intent(out)    :: Lder

    real(dp)    :: L_Nm1,L_Nm2
    real(dp)    :: Lder_Nm1,Lder_Nm2

    integer     :: i

    if (p == 0) then
      L                 = 1.0_dp
      Lder              = 0.0_dp

    else if (p == 1) then
      L                 = x
      Lder              = 1.0_dp

    else
        L_Nm2           = 1.0_dp
        L_Nm1           = x
        Lder_Nm2        = 0.0_dp
        Lder_Nm1        = 1.0_dp

        do i = 2,p
            L           = (real(2*i-1,dp)*x*L_Nm1 - real(i-1,dp)*L_Nm2)/real(i,dp)
            Lder        = Lder_Nm2 + real(2*i-1,dp)*L_Nm1
            L_Nm2       = L_Nm1
            L_Nm1       = L
            Lder_Nm2    = Lder_Nm1
            Lder_Nm1    = Lder
        end do
    end if

    !! normalize
    L    = L*SQRT(real(p,dp)+0.5)
    Lder = Lder*SQRT(real(p,dp)+0.5)

end subroutine
# endif

# if defined(PP_GAUSS_LOBATTO_NODES)
pure subroutine q_and_L_evaluation(p,x,q,dq,L_N)

    integer, intent(in)     :: p !! polynomial order
    real(dp), intent(in)    :: x
    real(dp), intent(out)   :: L_n,q,dq

    integer     :: k
    real(dp)    :: L_n_1,L_n_2,L_k,dL_n,dL_n_1,dL_n_2,dL_k

    L_N_2   = 1.0_dp
    L_N_1   = x
    dL_N_2  = 0.0_dp
    dL_N_1  = 1.0_dp

    do k = 2,p
        L_N     = (2.0_dp*real(k,dp) - 1.0_dp)/real(k,dp)*x*L_N_1 - (real(k,dp)-1.0_dp)/real(k,dp)*L_N_2
        dL_N    = dL_N_2 + (2.0_dp*real(k,dp) - 1.0_dp) * L_N_1
        L_N_2   = L_N_1
        L_N_1   = L_N
        dL_N_2  = dL_N_1
        dL_N_1  = dL_N
    end do

    !! take another step
    k       = p+1
    L_k     = (2.0_dp*real(k,dp) - 1.0_dp)/real(k,dp)*x*L_N - (real(k,dp) - 1.0_dp)/real(k,dp)*L_N_2
    dL_k    = dL_N_2 + (2.0_dp*real(k,dp) - 1.0_dp) * L_N_1
    q       = L_k - L_N_2
    dq      = dL_k - dL_N_2

end subroutine
# endif

pure subroutine equidistant_nodes_and_weights(N,nodes,weights)

    integer,intent(in)              :: N
    real(dp),intent(out)            :: nodes(N)
    real(dp),intent(out),optional   :: weights(N)

    integer :: i

    do i = 1,N
        nodes(i) = -1.0 + 2.0*(real(i,dp)-0.5)/real(N,dp)
    end do

    weights = 2.0/real(N,dp)

end subroutine

# if defined(PP_GAUSS_NODES)
pure subroutine Legendre_Gauss_nodes_and_weights(N,nodes,weights)

    integer,intent(in)      :: N !! number of nodes
    real(dp),intent(out)    :: nodes(n)
    real(dp),intent(out)    :: weights(n)

    integer, parameter      :: niter = 10

    integer  :: i,j
    real(dp) :: dx,cheb
    real(dp) :: L_Np1,Lder_Np1

    if (N == 1) then
        nodes   = 0.0_dp
        weights = 2.0_dp
        return
    end if

    if (N == 2) then
        nodes(1) = -sqrt(1.0_dp/3.0_dp)
        nodes(N) = -nodes(1)
        weights  = 1.0_dp
        return
    end if

    cheb = 2.0_dp*atan(1.0_dp)/real(N,dp)

    do i = 1,N/2
        !! initial guess
        nodes(i) = -cos(cheb*real(2*i-1,dp))

        !! Newton iteration
        do j = 1,nIter
            call Legendre_polynomial_and_derivative(N,nodes(i),L_Np1,Lder_Np1)

            dx = L_Np1/Lder_Np1
            nodes(i) = nodes(i) - dx

            if (abs(dx) < 10*tol*abs(nodes(i))) exit
        end do

        weights(i) = (2.0_dp*N + 1.0_dp)/((1.0_dp - nodes(i)*nodes(i))*Lder_Np1*Lder_Np1)

        !! symmetries
        nodes(N+1-i)    = -nodes(i)
        weights(N+1-i)  = weights(i)

    end do

    if (mod(N+1,2) .eq. 0) then
        call Legendre_polynomial_and_derivative(N,0.0_dp,L_Np1,Lder_Np1)
        nodes(N/2+1)    = 0.0_dp
        weights(N/2+1)  = (2.0_dp*N + 1.0_dp)/(Lder_Np1*Lder_Np1)
    end if

end subroutine
# endif

# if defined(PP_GAUSS_LOBATTO_NODES)
pure subroutine Legendre_Gauss_Lobatto_Nodes_And_Weights(N,nodes,weights)

    integer, intent(in)     :: N !! number of nodes
    real(dp), intent(out)   :: nodes(N)
    real(dp), intent(out)   :: weights(N)

    integer, parameter      :: niter = 10
    real(dp)                :: q,dq,L_n,delta

    integer                 :: i,j

    nodes(1)    = -1.0_dp
    weights(1)  =  2.0_dp / (real(N-1,dp)*real(N,dp))

    nodes(N)    = -nodes(1)
    weights(N)  = weights(1)

    if (N < 3) return

    do i = 2,N/2
        !! initial guess
        nodes(i) = -cos(((real(i-1,dp)+0.25_dp)*pi)/real(N-1,dp) - (3.0_dp/(8.0_dp*real(N-1,dp)*pi)) * (1.0_dp/(real(i-1,dp)+0.25_dp)))

        !! Newton iteration
        do j = 1,niter
            call q_And_L_Evaluation(N-1,nodes(i),q,dq,L_N)

            delta = q/dq
            nodes(i) = nodes(i) - delta

            if (abs(delta) < 10*tol*abs(nodes(i))) exit
        end do

        call q_And_L_Evaluation(N-1,nodes(i),q,dq,L_N)

        weights(i) = 2.0_dp / (real(N-1,dp)*real(N,dp) * L_N*L_N)

        nodes(N+1-i)    = -nodes(i)
        weights(N+1-i)  = weights(i)
    end do

    if (mod(N+1,2) == 0) then
        call q_And_L_Evaluation(N-1,0.0_dp,q,dq,L_N)

        nodes(N/2+1)    = 0.0_dp
        weights(N/2+1)  = 2.0_dp / (real(N-1,dp) * real(N,dp) * L_N*L_N)
    end if

end subroutine
# endif

!! ========================================================================== !!
!! public routines

subroutine kernel_utils_init()

    integer, parameter :: N = N_NODES

    real(dp) :: fvnodes(N_NODES), fvweights(N_NODES)
    real(dp) :: dgnodes(N_NODES), dgweights(N_NODES)

    real(dp) :: tempMat(N_NODES,N_NODES)

    integer :: i,j

    call Equidistant_Nodes_And_Weights(N_NODES,fvnodes,fvweights)

# if defined(PP_GAUSS_NODES)
    call Legendre_Gauss_Nodes_And_Weights(N_NODES,dgnodes,dgweights)
# elif defined(PP_GAUSS_LOBATTO_NODES)
    call Legendre_Gauss_Lobatto_Nodes_And_Weights(N_NODES,dgnodes,dgweights)
# else
# error No node type choosen!
# endif

    !! --------------------------------------------------------------------- !!
    !! Boundary Interpolation Operators

    do i = 1,N_NODES
        toBoundaryVecM(i) = lagrange_polynomial(N_NODES,dgnodes,i,-1.0_dp)
        toBoundaryVecP(i) = lagrange_polynomial(N_NODES,dgnodes,i, 1.0_dp)
    end do

    !! --------------------------------------------------------------------- !!
    !! Volume Term Matrix (weak form)

    call lagrange_Diff_Matrix(N_NODES,dgnodes,tempMat)
    forall (j = 1:N_NODES, i = 1:N_NODES)
        diffMat(i,j) = -2.0_dp * dgweights(j)/dgweights(i) * tempMat(j,i)
    end forall
    diffTam = transpose(diffMat)

    !! --------------------------------------------------------------------- !!
    !! Surface Term Matrix

    surfMat = 0.0_dp
    do i = 1,N_NODES
        surfMat(i,1) =  2.0_dp/dgweights(i) * lagrange_polynomial(N_NODES,dgnodes,i,-1.0_dp)
        surfMat(i,N) = -2.0_dp/dgweights(i) * lagrange_polynomial(N_NODES,dgnodes,i, 1.0_dp)
    end do
    surfTam = transpose(surfMat)

    !! --------------------------------------------------------------------- !!
    !! Visualization Matrix

    call lagrange_VanderMonde_Matrix(N_NODES,N_NODES,dgnodes,fvnodes,visuMat)
    visuTam = transpose(visuMat)

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

    refnodes = dgnodes
    refweights = dgweights

    !! Scaled it to unity.
    do j = 1,N_NODES; do i = 1,N_NODES
        refweights2D(i,j) = 0.25*refweights(i)*refweights(j)
    end do; end do

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

# if 0
    write (*,*) 'fvnodes', fvnodes
    write (*,*) 'dgnodes', dgnodes
    write (*,*) 'dgweights', dgweights
    write (*,*)

    write (*,*) 'toBoundaryVec{M,P}'
    write (*,'(32(ES12.4))') toBoundaryVecM
    write (*,'(32(ES12.4))') toBoundaryVecP
    write (*,*)

    write (*,*) 'diffMat'
    do i = 1,N_NODES
        write (*,'(32(ES12.4))') diffMat(i,:)
    end do
    write (*,*)

    write (*,*) 'surfMat'
    do i = 1,N_NODES
        write (*,'(32(ES12.4))') surfmat(i,:)
    end do
    write (*,*)
# endif

end subroutine

pure subroutine interpolate2visual(input,output)

    real(dp), intent(in) :: input(N_NODES,N_NODES)
    real(dp), intent(out) :: output(N_NODES,N_NODES)

    output = matmul(visuMat,matmul(input,visuTam))

end subroutine

end module


!******************************************************************************
!	Written for 'complexify.py 1.3'
!	J.R.R.A.Martins 1999
!       21-Apr-00  Fixed tan, sinh, cosh
!                  sign now returns complex
!                  added log10 and nint
!                  changed ==, /= and >= -- see comments below
!       20-May-00  added cosd, sind, and epsilon
!       11-Jul-00  took away cosd, sind (they are reserved, but not
!                  intrinsic functions in F90)
!       21-Jul-00  converted all trig functions to the value/derivative
!                  formulas -- not general complex number formulas
!       15-Aug-00  Fixed bug in atan2 formula and added the rest of the
!                  _ci and _ic cominations to the relational operators.
!                  P. Sturdza
!
!******************************************************************************
!
! Assume all code is compiled with double precision (-r8 compiler flag)
!

!TODO:
!     more typ combinations: cc, cr, rc, ic ?
!     check all fcns
!

module complexify

  implicit none

! ABS
  interface abs
     module procedure abs_c
  end interface

! COSD
!  interface cosd
!     module procedure cosd_c
!  end interface

! ACOS
  interface acos
     module procedure acos_c
  end interface

! SIND
!  interface sind
!     module procedure sind_c
!  end interface

! ASIN
  interface asin
     module procedure asin_c
  end interface

! ATAN
  interface atan
     module procedure atan_c
  end interface

! ATAN2
  interface atan2
     module procedure atan2_cc
  end interface

! COSH
  interface cosh
     module procedure cosh_c
  end interface

! MAX (limited to 2-4 complex args, 2 mixed args)
  interface max
     module procedure max_cc
     module procedure max_cr
     module procedure max_rc
     module procedure max_ccc     ! added because of DFLUX.f
     module procedure max_cccc     ! added because of DFLUX.f
  end interface

! MIN (limited to 2-4 complex args, 2 mixed args)
  interface min
     module procedure min_cc
     module procedure min_cr
     module procedure min_rc
     module procedure min_ccc
     module procedure min_cccc
  end interface

! MINVAL
  interface minval
      module procedure minval_c
  end interface minval

! MAXVAL
  interface maxval
      module procedure maxval_c
  end interface maxval

! SIGN
  interface sign
     module procedure sign_cc
     module procedure sign_cca
     module procedure sign_cr
     module procedure sign_rc
  end interface

! DIM
  interface dim
     module procedure dim_cc
     module procedure dim_cr
     module procedure dim_rc
  end interface

! SINH
  interface sinh
     module procedure sinh_c
  end interface

! TAN
  interface tan
     module procedure tan_c
  end interface

! TANH
  interface tanh
     module procedure tanh_c
  end interface

! LOG10
  interface log10
     module procedure log10_c
  end interface

! NINT
  interface nint
     module procedure nint_c
  end interface

! EPSILON
  interface epsilon
     module procedure epsilon_c
  end interface

! <
  interface operator (<)
     module procedure lt_cc
     module procedure lt_cr
     module procedure lt_rc
     module procedure lt_ci
     module procedure lt_ic
  end interface

! <=
  interface operator (<=)
     module procedure le_cc
     module procedure le_cr
     module procedure le_rc
     module procedure le_ci
     module procedure le_ic
  end interface

! >
  interface operator (>)
     module procedure gt_cc
     module procedure gt_cr
     module procedure gt_rc
     module procedure gt_ci
     module procedure gt_ic
     module procedure gt_cac
     module procedure gt_car
  end interface

!! MIPSpro Compilers: Version 7.30 won't take .ge. and .eq..
!! But pgf90 on Linux doesn't complain, go figure.
!! It looks like a strict interpretation of FORTRAN should
!! not allow overloading of .eq. and .ne. since they already
!! have a definition for type complex, so define new operators
!! called .ceq., .cne. and, for MIPS, .cge.
!!
!! comment out (and uncomment) the appropriate versions for
!! your compiler
!!
! >=
  interface operator (>=)
     module procedure ge_cc
     module procedure ge_cr
     module procedure ge_rc
     module procedure ge_ci
     module procedure ge_ic
  end interface
! interface operator (.cge.)
!    module procedure ge_cc
!    module procedure ge_rr
!    module procedure ge_ii
!    module procedure ge_aa
!    module procedure ge_cr
!    module procedure ge_rc
!    module procedure ge_ci
!    module procedure ge_ic
!    module procedure ge_ir
!    module procedure ge_ri
! end interface

! ==
!  interface operator (==)
!     module procedure eq_cc
!     module procedure eq_cr
!     module procedure eq_rc
!     module procedure eq_ci
!     module procedure eq_ic
!  end interface
  interface operator (.ceq.)
     module procedure eq_cc
     module procedure eq_rr
     module procedure eq_ii
     module procedure eq_iai
     module procedure eq_iaia
     module procedure eq_i8i8
     module procedure eq_i1i1
     module procedure eq_aa
     module procedure eq_cr
     module procedure eq_rc
     module procedure eq_ci
     module procedure eq_ic
     module procedure eq_ir
     module procedure eq_ri
  end interface

! /=
!  interface operator (/=)
!     module procedure ne_cc
!     module procedure ne_cr
!     module procedure ne_rc
!     module procedure ne_ci
!     module procedure ne_ic
!  end interface
  interface operator (.cne.)
     module procedure ne_cc
     module procedure ne_rr
     module procedure ne_ii
     module procedure ne_aa
     module procedure ne_cr
     module procedure ne_rc
     module procedure ne_ci
     module procedure ne_ic
     module procedure ne_ir
     module procedure ne_ri
  end interface

! floor
  interface floor
     module procedure floor_c
  end interface

contains

!******************************************************************************
!
!   Function definitions
!
!******************************************************************************

! ABS, intrinsic
  complex*16 function abs_c(val)
    complex*16, intent(in) :: val
    abs_c = val
    if (real(val) < 0) abs_c = cmplx(-real(val),-aimag(val))
    return
  end function abs_c

! COSD
!  complex*16 function cosd_c(z)
!    complex*16, intent(in) :: z
!    cosd_c = cos(z*3.14159265358979323846/180.)
!  end function cosd_c

! SIND
!  complex*16 function sind_c(z)
!    complex*16, intent(in) :: z
!    sind_c = sin(z*3.14159265358979323846/180.)
!  end function sind_c

! ACOS
  complex*16 function acos_c(z)
    complex*16, intent(in) :: z
!   acos_c = - cmplx(0., 1.)*log(z+sqrt(z**2-1.))
!   not general complex valued formula:
    acos_c = cmplx(acos(real(z)),-aimag(z)/sqrt(1.-real(z)**2))
    return
  end function acos_c

! ASIN
  complex*16 function asin_c(z)
    complex*16, intent(in) :: z
!   asin_c = - cmplx(0., 1.)*log(cmplx(0.,1.)*z+sqrt(1.-z**2))
!   not general complex valued formula:
    asin_c = cmplx(asin(real(z)),aimag(z)/sqrt(1.-real(z)**2))
    return
  end function asin_c

! ATAN
  complex*16 function atan_c(z)
    complex*16, intent(in) :: z
!   complex*16 z2
!   real*8 pi2, xans, yans, r, r2, x, y
!   pi2 = 2.0*atan(1.0)
!   r      = sqrt(real(z)**2+aimag(z)**2)
!   x      = real(z)
!   y      = aimag(z)
!   r2     = r*r
!   xans   = 0.5*atan2 (2.0*x, 1.0-r2)
!   yans   = 0.25*log((r2+2.0*y+1.0)/(r2-2.0*y+1.0))
!   atan_c = cmplx (xans, yans)
!   not general complex valued formula:
    atan_c = cmplx(atan(real(z)),aimag(z)/(1.+real(z)**2))
    return
  end function atan_c

! ATAN2
  complex*16 function atan2_cc(csn, ccs)
    complex*16, intent(in) :: csn, ccs
!   real*8 pi
!   pi = 4.0*atan(1.0)
!   if (sqrt(real(ccs)**2 + aimag(ccs)**2).eq.0.) then  ! abs orig
!     if (sqrt(real(csn)**2+aimag(csn)**2).eq.0.) then
!       atan2_cc = cmplx(0.0)
!     else
!       atan2_cc = cmplx(sign(0.5*pi,real(csn)), 0.0)
!     end if
!   else
!     atan2_cc = atan(csn/ccs)
!     if (real(ccs).lt.0.) atan2_cc = atan2_cc + pi
!     if (real(atan2_cc).gt.pi) atan2_cc = atan2_cc - 2.0*pi
!   end if
!   not general complex valued formula:
    real*8 a,b,c,d
    a=real(csn)
    b=aimag(csn)
    c=real(ccs)
    d=aimag(ccs)
    atan2_cc=cmplx(atan2(a,c),(c*b-a*d)/(a**2+c**2))
    return
  end function atan2_cc

! COSH
  complex*16 function cosh_c(z)
    complex*16, intent(in) :: z
!   complex*16 eplus, eminus
!   eplus = exp(z)
!   eminus = exp(z)
!   cosh_c = (eplus + eminus)/2.
!   not general complex valued formula:
    cosh_c=cmplx(cosh(real(z)),aimag(z)*sinh(real(z)))
    return
  end function cosh_c

! SINH
  complex*16 function sinh_c(z)
    complex*16, intent(in) :: z
!   complex*16 eplus, eminus
!   eplus = exp(z)
!   eminus = exp(z)
!   sinh_c = (eplus - eminus)/2.
!   not general complex valued formula:
    sinh_c=cmplx(sinh(real(z)),aimag(z)*cosh(real(z)))
    return
  end function sinh_c

! TAN
  complex*16 function tan_c(z)
    complex*16, intent(in) :: z
!   complex*16 eiplus, eiminus
!   eiplus = exp(cmplx(0.,1.)*z)
!   eiminus = exp(-cmplx(0.,1.)*z)
!   tan_c = cmplx(0.,1.)*(eiminus - eiplus)/(eiplus + eiminus)
!   not general complex valued formula:
    tan_c=cmplx(tan(real(z)),aimag(z)/cos(real(z))**2)
    return
  end function tan_c

! TANH
  complex*16 function tanh_c(a)
    complex*16, intent(in) :: a
!   complex*16 eplus, eminus
!   if(real(a) > 50)then
!     tanh_c = 1.
!   else
!     eplus = exp(a)
!     eminus = exp(-a)
!     tanh_c = (eplus - eminus)/(eplus + eminus)
!   end if
!   not general complex valued formula:
    tanh_c=cmplx(tanh(real(a)),aimag(a)/cosh(real(a))**2)
    return
  end function tanh_c

! MAX, intrinsic
  complex*16 function max_cc(val1, val2)
    complex*16, intent(in) :: val1, val2
    if (real(val1) > real(val2)) then
      max_cc = val1
    else
      max_cc = val2
    endif
    return
  end function max_cc
  complex*16 function max_cr(val1, val2)
    complex*16, intent(in) :: val1
    real*8, intent(in) :: val2
    if (real(val1) > val2) then
      max_cr = val1
    else
      max_cr = cmplx(val2, 0.)
    endif
    return
  end function max_cr
  complex*16 function max_rc(val1, val2)
    real*8, intent(in) :: val1
    complex*16, intent(in) :: val2
    if (val1 > real(val2)) then
      max_rc = cmplx(val1, 0.)
    else
      max_rc = val2
    endif
    return
  end function max_rc
  complex*16 function max_ccc(val1, val2, val3)
    complex*16, intent(in) :: val1, val2, val3
    if (real(val1) > real(val2)) then
      max_ccc = val1
    else
      max_ccc = val2
    endif
    if (real(val3) > real(max_ccc)) then
      max_ccc = val3
    endif
    return
  end function max_ccc
  function max_cccc(val1, val2, val3, val4)
    complex*16, intent(in) :: val1, val2, val3, val4
    complex*16 max_cccc
    complex*16 max_cccc2
    if (real(val1) > real(val2)) then
      max_cccc = val1
    else
      max_cccc = val2
    endif
    if (real(val3) > real(val4)) then
      max_cccc2 = val3
    else
      max_cccc2 = val4
    endif
    if (real(max_cccc2) > real(max_cccc)) then
      max_cccc = max_cccc2
    endif
    return
  end function max_cccc

! MIN, intrinsic
  complex*16 function min_cc(val1, val2)
    complex*16, intent(in) :: val1, val2
    if (real(val1) < real(val2)) then
      min_cc = val1
    else
      min_cc = val2
    endif
    return
  end function min_cc
  complex*16 function min_cr(val1, val2)
    complex*16, intent(in) :: val1
    real*8, intent(in) :: val2
    if (real(val1) < val2) then
      min_cr = val1
    else
      min_cr = cmplx(val2, 0.)
    endif
    return
  end function min_cr
  complex*16 function min_rc(val1, val2)
    real*8, intent(in) :: val1
    complex*16, intent(in) :: val2
    if (val1 < real(val2)) then
      min_rc = cmplx(val1, 0.)
    else
      min_rc = val2
    endif
    return
  end function min_rc
  complex*16 function min_ccc(val1, val2, val3)
    complex*16, intent(in) :: val1, val2, val3
    if (real(val1) < real(val2)) then
      min_ccc = val1
    else
      min_ccc = val2
    endif
    if (real(val3) < real(min_ccc)) then
      min_ccc = val3
    endif
    return
  end function min_ccc
  function min_cccc(val1, val2, val3, val4)
    complex*16, intent(in) :: val1, val2, val3, val4
    complex*16 min_cccc
    complex*16 min_cccc2
    if (real(val1) < real(val2)) then
      min_cccc = val1
    else
      min_cccc = val2
    endif
    if (real(val3) < real(val4)) then
      min_cccc2 = val3
    else
      min_cccc2 = val4
    endif
    if (real(min_cccc2) < real(min_cccc)) then
      min_cccc = min_cccc2
    endif
    return
  end function min_cccc

! MINVAL: minimum of an array
! Assumes a 1D array!
  complex*16 function minval_c(z)
    complex*16, intent(in) :: z(:)
    minval_c = cmplx(minval(real(z)), aimag(z(minloc(real(z),dim=1))))
  end function minval_c

! MAXVAL: maximum of an array
! Assumes a 1D array!
  complex*16 function maxval_c(z)
    complex*16, intent(in) :: z(:)
    maxval_c = cmplx(maxval(real(z)), aimag(z(maxloc(real(z),dim=1))))
  end function maxval_c

!! MINLOC: location of minimum in an array
!  complex*16 function minloc_c(z)
!    complex*16, intent(in) :: z(:)
!    !integer n
!    !n = size(z)
!    minloc_c = minloc(real(z))
!  end function minval_c

! SIGN, intrinsic, assume that val1 is always a complex*16
!                  in reality could be int
  complex*16 function sign_cc(val1, val2)
    complex*16, intent(in) :: val1, val2
    real*8  sign
    if (real(val2) < 0.) then
      sign = -1.
    else
      sign = 1.
    endif
    sign_cc = sign * val1
    return
  end function sign_cc
  function sign_cca(val1, val2) ! NEW, not verified
    complex*16, intent(in) :: val1
    complex*16, intent(in) :: val2(:)
    complex*16 sign_cca(size(val2))
    real*8 sign
    integer i, n
    n = size(val2)
    do i = 1, n
       if (real(val2(i)) < 0.) then
          sign = -1.
       else
          sign = 1.
       endif
       sign_cca(i) = sign * val1
    enddo
    return
  end function sign_cca
  complex*16 function sign_cr(val1, val2)
    complex*16, intent(in) :: val1
    real*8, intent(in) :: val2
    real*8 sign
    if (real(val2) < 0.) then
      sign = -1.
    else
      sign = 1.
    endif
    sign_cr = sign * val1
    return
  end function sign_cr
  complex*16 function sign_rc(val1, val2)
    real*8, intent(in) :: val1
    complex*16, intent(in) :: val2
    real*8 sign
    if (real(val2) < 0.) then
      sign = -1.
    else
      sign = 1.
    endif
    sign_rc = sign * val1
    return
  end function sign_rc

! DIM, intrinsic
  complex*16 function dim_cc(val1, val2)
    complex*16, intent(in) :: val1, val2
    if (val1 > val2) then
      dim_cc = val1 - val2
    else
      dim_cc = cmplx(0., 0.)
    endif
    return
  end function dim_cc
  complex*16 function dim_cr(val1, val2)
    complex*16, intent(in) :: val1
    real*8, intent(in) :: val2
    if (val1 > val2) then
      dim_cr = val1 - cmplx(val2, 0.)
    else
      dim_cr = cmplx(0., 0.)
    endif
    return
  end function dim_cr
  complex*16 function dim_rc(val1, val2)
    real*8, intent(in) :: val1
    complex*16, intent(in) :: val2
    if (val1 > val2) then
      dim_rc = cmplx(val1, 0.) - val2
    else
      dim_rc = cmplx(0., 0.)
    endif
    return
  end function dim_rc

! LOG10
  complex*16 function log10_c(z)
    complex*16, intent(in) :: z
    log10_c=log(z)/log((10.0,0.0))
  end function log10_c

! NINT
  integer function nint_c(z)
    complex*16, intent(in) :: z
    nint_c = nint(real(z))
  end function nint_c

! EPSILON !! bad news ulness compiled with -r8
  complex*16 function epsilon_c(z)
    complex*16, intent(in) :: z
    epsilon_c=epsilon(real(z))
  end function epsilon_c

! <, .lt.
  logical function lt_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    lt_cc = real(lhs) < real(rhs)
  end function lt_cc
  logical function lt_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    lt_cr = real(lhs) < rhs
  end function lt_cr
  logical function lt_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    lt_rc = lhs < real(rhs)
  end function lt_rc
  logical function lt_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    lt_ci = real(lhs) < rhs
  end function lt_ci
  logical function lt_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    lt_ic = lhs < real(rhs)
  end function lt_ic

! <=, .le.
  logical function le_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    le_cc = real(lhs) <= real(rhs)
  end function le_cc
  logical function le_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    le_cr = real(lhs) <= rhs
  end function le_cr
  logical function le_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    le_rc = lhs <= real(rhs)
  end function le_rc
  logical function le_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    le_ci = real(lhs) <= rhs
  end function le_ci
  logical function le_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    le_ic = lhs <= real(rhs)
  end function le_ic

! >, .gt.
  logical function gt_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    gt_cc = real(lhs) > real(rhs)
  end function gt_cc
  logical function gt_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    gt_cr = real(lhs) > rhs
  end function gt_cr
  logical function gt_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    gt_rc = lhs > real(rhs)
  end function gt_rc
  logical function gt_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    gt_ci = real(lhs) > rhs
  end function gt_ci
  logical function gt_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    gt_ic = lhs > real(rhs)
  end function gt_ic
!  function gt_caca(lhs, rhs) ! Arrays
!    complex*16, intent(in) :: lhs(:), rhs(:)
!    logical gt_caca(size(lhs))
!    integer n
!    n = size(lhs)
!    gt_caca = real(lhs) > real(rhs)
!  end function gt_caca
  function gt_cac(lhs, rhs) ! Arrays
    complex*16, intent(in) :: lhs(:)
    complex*16, intent(in) :: rhs
    logical gt_cac(size(lhs))
    integer n
    n = size(lhs)
    gt_cac = real(lhs) > real(rhs)
  end function gt_cac
  function gt_car(lhs, rhs) ! Arrays
    complex*16, intent(in) :: lhs(:)
    real*8, intent(in) :: rhs
    logical gt_car(size(lhs))
    integer n
    n = size(lhs)
    gt_car = real(lhs) > rhs
  end function gt_car

!! here are the redefined ones:
! >=, .ge.
  logical function ge_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    ge_cc = real(lhs) >= real(rhs)
  end function ge_cc
  logical function ge_rr(lhs, rhs)
    real*8, intent(in) :: lhs, rhs
    ge_rr = lhs >= rhs
  end function ge_rr
  logical function ge_ii(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    ge_ii = lhs >= rhs
  end function ge_ii
  logical function ge_aa(lhs, rhs)
    character(len=*), intent(in) :: lhs, rhs
    ge_aa = lhs >= rhs
  end function ge_aa
  logical function ge_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    ge_cr = real(lhs) >= rhs
  end function ge_cr
  logical function ge_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    ge_rc = lhs >= real(rhs)
  end function ge_rc
  logical function ge_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    ge_ci = real(lhs) >= rhs
  end function ge_ci
  logical function ge_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    ge_ic = lhs >= real(rhs)
  end function ge_ic
  logical function ge_ir(lhs, rhs)
    integer, intent(in) :: lhs
    real*8, intent(in) :: rhs
    ge_ir = lhs >= rhs
  end function ge_ir
  logical function ge_ri(lhs, rhs)
    real*8, intent(in) :: lhs
    integer, intent(in) :: rhs
    ge_ri = lhs >= rhs
  end function ge_ri

! ==, .eq.
  logical function eq_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    eq_cc = real(lhs) == real(rhs)
  end function eq_cc
  logical function eq_rr(lhs, rhs)
    real*8, intent(in) :: lhs, rhs
    eq_rr = lhs == rhs
  end function eq_rr
  logical function eq_ii(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    eq_ii = lhs == rhs
  end function eq_ii
  ! lhs and rhs are rank 1 integer arrays
  function eq_iaia(lhs, rhs)
    integer, intent(in) :: lhs(:), rhs(:)
    logical eq_iaia(size(lhs))
    eq_iaia = lhs == rhs
  end function eq_iaia
  ! lhs is a rank 3 integer array
  function eq_iai(lhs, rhs)
    integer, intent(in) :: lhs(:,:,:)
    integer, intent(in) :: rhs
    logical eq_iai(size(lhs,1), size(lhs,2), size(lhs,3))
    eq_iai = lhs == rhs
  end function eq_iai
  logical function eq_i8i8(lhs, rhs)
    integer(kind = 8), intent(in) :: lhs, rhs
    eq_i8i8 = lhs == rhs
  end function eq_i8i8
  logical function eq_i1i1(lhs, rhs)
    integer(kind = 1), intent(in) :: lhs, rhs
    eq_i1i1 = lhs == rhs
  end function eq_i1i1
  logical function eq_aa(lhs, rhs)
    character(len=*), intent(in) :: lhs, rhs
    eq_aa = lhs == rhs
  end function eq_aa
  logical function eq_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    eq_cr = real(lhs) == rhs
  end function eq_cr
  logical function eq_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    eq_rc = lhs == real(rhs)
  end function eq_rc
  logical function eq_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    eq_ci = real(lhs) == rhs
  end function eq_ci
  logical function eq_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    eq_ic = lhs == real(rhs)
  end function eq_ic
  logical function eq_ir(lhs, rhs)
    integer, intent(in) :: lhs
    real*8, intent(in) :: rhs
    eq_ir = lhs == rhs
  end function eq_ir
  logical function eq_ri(lhs, rhs)
    real*8, intent(in) :: lhs
    integer, intent(in) :: rhs
    eq_ri = lhs == rhs
  end function eq_ri

! /=, .ne.
  logical function ne_cc(lhs, rhs)
    complex*16, intent(in) :: lhs, rhs
    ne_cc = real(lhs) /= real(rhs)
  end function ne_cc
  logical function ne_rr(lhs, rhs)
    real*8, intent(in) :: lhs, rhs
    ne_rr = lhs /= rhs
  end function ne_rr
  logical function ne_ii(lhs, rhs)
    integer, intent(in) :: lhs, rhs
    ne_ii = lhs /= rhs
  end function ne_ii
  logical function ne_aa(lhs, rhs)
    character(len=*), intent(in) :: lhs, rhs
    ne_aa = lhs /= rhs
  end function ne_aa
  logical function ne_cr(lhs, rhs)
    complex*16, intent(in) :: lhs
    real*8, intent(in) :: rhs
    ne_cr = real(lhs) /= rhs
  end function ne_cr
  logical function ne_rc(lhs, rhs)
    real*8, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    ne_rc = lhs /= real(rhs)
  end function ne_rc
  logical function ne_ci(lhs, rhs)
    complex*16, intent(in) :: lhs
    integer, intent(in) :: rhs
    ne_ci = real(lhs) /= rhs
  end function ne_ci
  logical function ne_ic(lhs, rhs)
    integer, intent(in) :: lhs
    complex*16, intent(in) :: rhs
    ne_ic = lhs /= real(rhs)
  end function ne_ic
  logical function ne_ir(lhs, rhs)
    integer, intent(in) :: lhs
    real*8, intent(in) :: rhs
    ne_ir = lhs /= rhs
  end function ne_ir
  logical function ne_ri(lhs, rhs)
    real*8, intent(in) :: lhs
    integer, intent(in) :: rhs
    ne_ri = lhs /= rhs
  end function ne_ri

! floor: the largest integer less than or equal to the argument
  function floor_c(z)
    complex*16, intent(in) :: z(:)
    complex*16 floor_c(size(z))
    integer n
    n = size(z)
    floor_c = floor(real(z(1:n)))
  end function floor_c

end module complexify