c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c $Rev: 55 $ $Date: 2014-12-31 12:16:59 -0500 (Wed, 31 Dec 2014) $
c FORTRAN 77
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      REAL FUNCTION BDREF(MU, MUP, DPHI,
     &                     BRDF_TYPE, BRDF_ARG)

c     Supplies surface bi-directional reflectivity.
c
c     NOTE 1: Bidirectional reflectivity in DISORT is defined
c             by Eq. 39 in STWL.
c     NOTE 2: Both MU and MU0 (cosines of reflection and incidence
c             angles) are positive.
c
c  INPUT:
c
c    MU     : Cosine of angle of reflection (positive)
c
c    MUP    : Cosine of angle of incidence (positive)
c
c    DPHI   : Difference of azimuth angles of incidence and reflection
c                (radians)
c
c  LOCAL VARIABLES:
c
c    IREF   : bidirectional reflectance options
c             1 - Hapke's BDR model
c             2 - Cox-Munk BDR model
c             3 - RPV BDR model
c             4 - Ross-Li BDR model
c
c    B0     : empirical factor to account for the finite size of
c             particles in Hapke's BDR model
c
c    B      : term that accounts for the opposition effect
c             (retroreflectance, hot spot) in Hapke's BDR model
c
c    CTHETA : cosine of phase angle in Hapke's BDR model
c
c    GAMMA  : albedo factor in Hapke's BDR model
c
c    H0     : H( mu0 ) in Hapke's BDR model
c
c    H      : H( mu ) in Hapke's BDR model
c
c    HH     : angular width parameter of opposition effect in Hapke's
c             BDR model
c
c    P      : scattering phase function in Hapke's BDR model
c
c    THETA  : phase angle (radians); the angle between incidence and
c             reflection directions in Hapke's BDR model
c
c    W      : single scattering albedo in Hapke's BDR model
c
c
c   Called by- DREF, SURFAC
c +-------------------------------------------------------------------+
c     .. Scalar Arguments ..
      REAL      DPHI, MU, MUP, BRDF_ARG(6)
      INTEGER   BRDF_TYPE
c     ..
c     .. Local Scalars ..
      INTEGER   IREF
      REAL      B0, H0, HH, W
      REAL      PWS, REFRAC_INDEX, BDREF_F
      REAL      PI
      REAL      RHO0, KAPPA, G
      REAL      K_ISO, K_VOL, K_GEO, ALPHA0
      LOGICAL   DO_SHADOW
c     Additions for pyRT_DISORT
      REAL      ASYM, FRAC, ROUGHNESS
c     ..
c     .. External Subroutines ..
      EXTERNAL  ERRMSG
c     ..
c     .. Intrinsic Functions ..
      INTRINSIC COS, SQRT
c     ..

      PI   = 2.*ASIN(1.)

      IREF = BRDF_TYPE

c     ** 1. Hapke BRDF
      IF ( IREF.EQ.1 ) THEN

c       ** Hapke's BRDF model (times Pi/Mu0) (Hapke, B., Theory of reflectance
c       ** and emittance spectroscopy, Cambridge University Press, 1993, Eq.
c       ** 8.89 on page 233. Parameters are from Fig. 8.15 on page 231, expect
c       ** for w.)

        B0 = BRDF_ARG(1) !1.0
        HH = BRDF_ARG(2) !0.06
        W  = BRDF_ARG(3) !0.6

        CALL BRDF_HAPKE(MUP, MU, DPHI,
     &                  B0, HH, W, PI,
     &                  BDREF)

c     ** 2. Cox-Munk BRDF
      ELSEIF(IREF.EQ.2) THEN

c        PRINT *, "Calling oceabrdf"

        PWS          =  BRDF_ARG(1)
        REFRAC_INDEX =  BRDF_ARG(2)

        IF(BRDF_ARG(3) .EQ. 1) THEN
          DO_SHADOW = .TRUE.
        ELSEIF(BRDF_ARG(3) .EQ. 0) THEN
          DO_SHADOW = .FALSE.
        ELSE
          PRINT *, "ERROR SHADOW ARGUMENTS"
        ENDIF

        CALL OCEABRDF2(DO_SHADOW,
     &                 REFRAC_INDEX, PWS,
     &                 MUP, MU, DPHI,
     &                 BDREF_F)

        BDREF = BDREF_F

c     ** 3. RPV BRDF
      ELSEIF(IREF .EQ. 3) THEN

        RHO0  =  BRDF_ARG(1) !0.027
        KAPPA =  BRDF_ARG(2) !0.647
        G     =  BRDF_ARG(3) !-0.169   !asymmetry factor for HG
        H0    =  BRDF_ARG(4) !0.100

        CALL BRDF_RPV(MUP, MU, DPHI,
     &                RHO0, KAPPA, G, H0,
     &                BDREF_F)

        BDREF = BDREF_F

c     ** 4. Ross-Li BRDF
      ELSEIF(IREF .EQ. 4) THEN

        K_ISO  = BRDF_ARG(1)   !0.200
        K_VOL  = BRDF_ARG(2)   !0.020
        K_GEO  = BRDF_ARG(3)   !0.300
        ALPHA0 = 1.5*pi/180.

        CALL BRDF_ROSSLI(MUP, MU, DPHI,
     &                   K_ISO, K_VOL, K_GEO,
     &                   ALPHA0,
     &                   BDREF_F)

        BDREF = BDREF_F

        IF(BDREF .LT. 0.00) THEN
          BDREF = 0.00
        ENDIF

c     ** 5. Hapke + HG2 BRDF
      ELSEIF ( IREF.EQ.5 ) THEN

        B0 = BRDF_ARG(1) !1.0
        HH = BRDF_ARG(2) !0.06
        W  = BRDF_ARG(3) !0.6
        ASYM = BRDF_ARG(4)
        FRAC = BRDF_ARG(5)

        CALL BRDF_HAPKE_HG2(MUP, MU, DPHI,
     &                  B0, HH, W, ASYM, FRAC, PI,
     &                  BDREF)

c     ** 6. Hapke + HG2 with roughness
      ELSEIF ( IREF.EQ.6 ) THEN

        B0 = BRDF_ARG(1) !1.0
        HH = BRDF_ARG(2) !0.06
        W  = BRDF_ARG(3) !0.6
        ASYM = BRDF_ARG(4)
        FRAC = BRDF_ARG(5)
        ROUGHNESS = BRDF_ARG(6)

        CALL BRDF_HAPKE_HG2_ROUGHNESS(MUP, MU, DPHI,
     &                  B0, HH, W, ASYM, FRAC, ROUGHNESS, PI,
     &                  BDREF)

      ELSE

        CALL ERRMSG( 'BDREF--Need to supply surface BDRF model',
     &                 .TRUE.)

      ENDIF

      RETURN
      END FUNCTION
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_HAPKE ( MUP, MU, DPHI,
     &                        B0, HH, W, PI,
     &                        BRDF )

c +--------------------------------------------------------------------
c Hapke "Theory of Reflectance and Emittance Spectroscopy" Chapter 10, Page 262
c Eq. (10.2).
c Version 3 fix: definition of phase angle / scattering angle see DISORT3
c paper Eqs. (25-26).
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MUP, MU, DPHI
      REAL B0, HH, W, PI
      REAL BRDF
      REAL CALPHA, ALPHA, P, B, H0, GAMMA, H

      CALPHA = MU * MUP - (1.-MU**2)**.5 * (1.-MUP**2)**.5
     &         * COS( DPHI )

      ALPHA = ACOS( CALPHA )

      P     = 1. + 0.5 * CALPHA

      B     = B0 * HH / ( HH + TAN( ALPHA/2.) )

      GAMMA = SQRT( 1. - W )
      H0   = ( 1. + 2.*MUP ) / ( 1. + 2.*MUP * GAMMA )
      H    = ( 1. + 2.*MU ) / ( 1. + 2.*MU * GAMMA )

c     ** Version 3: add factor PI
      BRDF = W / (4.*PI) / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )
c     BRDF = W / 4. / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_RPV(MU_I, MU_R, DPHI,
     &                    RHO0, KAPPA, G_HG, H0,
     &                    BRDF)

c +--------------------------------------------------------------------
c DISORT Version 3: RPV BRDF
c   Input:
c
c   MU_I:  absolute cosine of incident polar angle (positive)
c   MU_R:  absolute cosine of reflected polar angle (positive)
c   DPHI:  relative azimuth to incident vector; (pi - dphi), sun-view relative
c          azimuth sun located at phi = 180, while incident solar beam located
c          at phi = 0
c   RHO0:  RPV BRDF parameter, control reflectance
c   KAPPA: PRV BRDF parameter, control anisotropy
c   G:     RPV BRDF parameter, H-G asymmetry factor
c   H0:    RPV BRDF parameter, control hot spot (back scattering direction)
c
c   Output:
c
c   BRDF:  RPV BRDF
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MU_I, MU_R, DPHI
      REAL RHO0, KAPPA, G_HG, H0
      REAL BRDF
      REAL PI
      REAL COS_ALPHA
      REAL SIN_I, SIN_R, TAN_I, TAN_R
      REAL G_SQ, G, F

      PI    = 2.*ASIN(1.)

      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)
      TAN_I = SIN_I/MU_I
      TAN_R = SIN_R/MU_R

      COS_ALPHA = MU_I*MU_R - SIN_I*SIN_R
     & *COS(DPHI)

      G_SQ = TAN_I*TAN_I + TAN_R*TAN_R
     &    + 2.*TAN_I*TAN_R*COS(DPHI)

c     ** hot spot
      G = SQRT(G_SQ)

c     ** HG phase function
      F = (1. - G_HG*G_HG)/
     &     (1+G_HG*G_HG+2.*G_HG*COS_ALPHA)**1.5

c     ** BRDF semiempirical function
      BRDF = RHO0
     &      * (MU_I*MU_R*(MU_I+MU_R))**(KAPPA-1.)
     &      * F
     &      * (1. + ((1.-H0)/(1.+G)))

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE BRDF_ROSSLI(MU_I, MU_R, DPHI,
     &                       K_ISO, K_VOL, K_GEO,
     &                       ALPHA0,
     &                       BRDF)

c +--------------------------------------------------------------------
c Version 3: Ross-Li BRDF
c   Input:
c
c   MU_I:    absolute cosine of incident polar angle (positive)
c   MU_R:    absolute cosine of reflected polar angle (positive)
c   DPHI:  relative azimuth to incident vector; (pi - dphi), sun-view relative
c          azimuth sun located at phi = 180, while incident solar beam located
c          at phi = 0
c   K_ISO:   BRDF parameter, isotropic scattering kernel
c   K_VOL:   BRDF parameter, volume scattering kernel
c   K_GEO:   BRDF parameter, geometry scattering kernel
c   ALPHA0:  BRDF parameter, control hot spot (back scattering direction)
c
c   Output:
c   BRDF:  Ross-Li BRDF
c
c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MU_I, MU_R, DPHI
      REAL F_GEO, F_VOL
      REAL K_ISO, K_GEO, K_VOL
      REAL RATIO_HB, RATIO_BR
      REAL BRDF
      REAL PI
      REAL COS_ALPHA, SIN_ALPHA
      REAL COS_ALPHA1
      REAL ALPHA
      REAL SIN_I, SIN_R, TAN_I, TAN_R
      REAL SIN_I1, SIN_R1, COS_I1, COS_R1, TAN_I1, TAN_R1
      REAL G_SQ, COS_T, T
      REAL C, ALPHA0
c +--------------------------------------------------------------------

c      PRINT *, MU_I, MU_R, DPHI,
c     &        K_ISO, K_GEO, K_VOL,
c     &        THETA0
c      PRINT *,

      RATIO_HB = 2.
      RATIO_BR = 1.
      PI       = 2.*ASIN(1.)

      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)
      TAN_I = SIN_I/MU_I
      TAN_R = SIN_R/MU_R

      COS_ALPHA = MU_I*MU_R - SIN_I*SIN_R
     & *COS(DPHI)
      SIN_ALPHA = SQRT(1. - COS_ALPHA*COS_ALPHA)
      ALPHA = ACOS(COS_ALPHA)

c     ** Compute KERNEL RossThick
      C     = 1. + 1./(1.+ALPHA/ALPHA0)
      F_VOL = 4./(3.*PI) * (1./(MU_I+MU_R))
     &       * ((PI/2. - ALPHA)*COS_ALPHA+SIN_ALPHA)*C - 1./3.

c      K1 = ((PI/2. - ALPHA)*COS_ALPHA + SIN_ALPHA)
c     &       /(MU_I + MU_R) - PI/4.

c     ** Compute KERNEL LSR
      TAN_I1 = RATIO_BR * TAN_I
      TAN_R1 = RATIO_BR * TAN_R
      SIN_I1 = TAN_I1/SQRT(1.+ TAN_I1*TAN_I1)
      SIN_R1 = TAN_R1/SQRT(1.+ TAN_R1*TAN_R1)
      COS_I1 = 1./SQRT(1.+ TAN_I1*TAN_I1)
      COS_R1 = 1./SQRT(1.+ TAN_R1*TAN_R1)

      COS_ALPHA1 = COS_I1*COS_R1 - SIN_I1*SIN_R1
     &            *COS(DPHI)

      G_SQ = TAN_I1*TAN_I1 + TAN_R1*TAN_R1
     &      + 2.*TAN_I1*TAN_R1*COS(DPHI)

c      M = 1./COS_I1 + 1./COS_R1

      COS_T = RATIO_HB *(COS_I1*COS_R1)/(COS_I1+COS_R1)
     &       *SQRT(G_SQ + (TAN_I1*TAN_R1*SIN(DPHI))**2)

      IF(COS_T .LE. 1. .AND. COS_T .GE. -1.) THEN
        T = ACOS(COS_T)
      ELSE
        T = 0.
      ENDIF

      F_GEO = (COS_I1+COS_R1)/(PI*COS_I1*COS_R1)*(T-SIN(T)*COS(T)-PI)
     &       + (1.+ COS_ALPHA1)/(2.*COS_I1*COS_R1)

c     Compute BRDF

c      PRINT *, RATIO_HB, D_SQ,
c     &    TAN_I1*TAN_R1*SIN(DPHI),
c     &    M, COS_T

c      BRDF = K1
      BRDF = K_ISO + K_GEO*F_GEO + K_VOL*F_VOL

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      SUBROUTINE OCEABRDF2
     &       ( DO_SHADOW,
     &         REFRAC_INDEX, WS,
     &         MU_I, MU_R, DPHI,
     &         BRDF)

c +--------------------------------------------------------------------
c Version 3: 1D Gaussian Rough Ocean BRDF
c   Input:
c
c   mu_i:         absolute cosine of incident polar angle (positive)
c   mu_r:         absolute cosine of reflected polar angle (positive)
c   dphi:         relative azimuth (radians)
c   do_shadow:    BRDF parameter, open/close shadow effect
c   refrac_index: BRDF parameter, refractive index of boundary media (water)
c   ws:           BRDF parameter, wind speed (m/s)
c
c   Output:
c
c   brdf:         1D Gaussian Rough Ocean BRDF
c
c +--------------------------------------------------------------------
      LOGICAL  DO_SHADOW
      REAL     REFRAC_INDEX, WS
      REAL     SIN_I, SIN_R, MU_I, MU_R, DPHI, BRDF
      REAL     COS_THETA, SIGMA_SQ, MU_N_SQ, P
      REAL     N_I, N_T, COS_LI, COS_LT, SIN_LI, SIN_LT
      REAL     R_S, R_P, R
      REAL     SHADOW
      REAL     PI

      PI = 2.*ASIN(1.)

c     ** Cox Munk slope distribution
      SIN_I = SQRT(1. - MU_I*MU_I)
      SIN_R = SQRT(1. - MU_R*MU_R)

      COS_THETA = -MU_I*MU_R + SIN_I*SIN_R*COS(DPHI)
      MU_N_SQ   = (MU_I + MU_R)*(MU_I + MU_R)/(2.*(1.-COS_THETA))

      SIGMA_SQ  = 0.003 + 0.00512*WS

      P = 1./(PI*SIGMA_SQ) * EXP( -(1-MU_N_SQ)/(SIGMA_SQ*MU_N_SQ) )

c     ** Fresnel reflectance

      N_I = 1.0
      N_T = REFRAC_INDEX

      SIN_LI = SQRT( 1.-0.5*(1.-COS_THETA) )
      COS_LI = SQRT( 0.5*(1.-COS_THETA) )
      SIN_LT = N_I*SIN_LI/N_T
      COS_LT = SQRT(1. - SIN_LT*SIN_LT)

      R_S = (N_I*COS_LI-N_T*COS_LT)/(N_I*COS_LI+N_T*COS_LT)
      R_P = (N_T*COS_LI-N_I*COS_LT)/(N_I*COS_LT+N_T*COS_LI)

      R = 0.5*(R_S*R_S + R_P*R_P)

c     ** Rough surface BRDF
      BRDF = (P*R)/(4.*MU_I*MU_R*MU_N_SQ*MU_N_SQ)

c     Shadowing effect (see Tsang, Kong, Shin, Theory of Microwave Remote
c     Sensing, Wiley-Interscience, 1985)
      IF(DO_SHADOW) THEN
        SHADOW = 1./( SHADOW_ETA(MU_I, SIGMA_SQ, PI)
     &          + SHADOW_ETA(MU_R, SIGMA_SQ, PI) + 1. )
        BRDF = BRDF*SHADOW
      ENDIF

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c +--------------------------------------------------------------------
      REAL FUNCTION SHADOW_ETA(COS_THETA, SIGMA_SQ, PI)
c +--------------------------------------------------------------------
c Version 3: shadow effect function
c            called by OCEABRDF2
c   Input:
c
c   COS_THETA     absolute cosine of incident/reflected polar angle (positive)
c   SIGMA_SQ      slope variance
c   PI            3.141592653... constant
c
c   Output:
c
c   SHADOW_ETA:   shadow function
c +--------------------------------------------------------------------
      REAL COS_THETA, SIN_THETA
      REAL MU, SIGMA_SQ, PI
      REAL TERM1, TERM2

      SIN_THETA = SQRT(1.-COS_THETA*COS_THETA)
      MU = COS_THETA/SIN_THETA

      TERM1 = SQRT(SIGMA_SQ/PI)/MU*EXP( -MU*MU/(SIGMA_SQ) )
      TERM2 = ERFC( MU/SQRT(SIGMA_SQ) )

      SHADOW_ETA = 0.5*(TERM1 - TERM2)

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c Start pyRT_DISORT additions
c Hapke + HG2 surface
c +--------------------------------------------------------------------
      SUBROUTINE BRDF_HAPKE_HG2 ( MUP, MU, DPHI,
     &                        B0, HH, W, ASYM, FRAC, PI,
     &                        BRDF )

c +--------------------------------------------------------------------

c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MUP, MU, DPHI
      REAL B0, HH, W, PI
      REAL BRDF
      REAL CALPHA, ALPHA, P, B, H0, GAMMA, H
      REAL ASYM, FRAC
      REAL CTHETA, THETA, FORWARD, BACKWARD, PSI

      CALPHA = MU * MUP - (1.-MU**2)**.5 * (1.-MUP**2)**.5
     &         * COS( DPHI )

      ALPHA = ACOS( CALPHA )

      B     = B0 * HH / ( HH + TAN( ALPHA/2.) )

      GAMMA = SQRT( 1. - W )
      H0   = ( 1. + 2.*MUP ) / ( 1. + 2.*MUP * GAMMA )
      H    = ( 1. + 2.*MU ) / ( 1. + 2.*MU * GAMMA )

      FORWARD = (1. - ASYM**2.) / (1. + 2. * ASYM * COS(ALPHA) +
     &           ASYM**2.)**1.5
      BACKWARD = (1. - ASYM**2.) / (1. - 2. * ASYM * COS(ALPHA) +
     &           ASYM**2.)**1.5

      P = FRAC * FORWARD + (1-FRAC)*BACKWARD

c     ** Version 3: add factor PI
      BRDF = W / (4.*PI) / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )

c      BRDF = W / 4. / (MU+MUP) * ( (1.+B)* P + H0 * H - 1.0 )

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c Just copy Mike's code/logic here
c +--------------------------------------------------------------------
      SUBROUTINE BRDF_HAPKE_HG2_ROUGHNESS ( MUP, MU, DPHI,
     &                        B0, HH, W, ASYM, FRAC, ROUGHNESS, PI,
     &                        BRDF )

c +--------------------------------------------------------------------

c +--------------------------------------------------------------------
      IMPLICIT NONE
      REAL MUP, MU, DPHI
      REAL B0, HH, W, PI
      REAL BRDF, P, B
      REAL ASYM, FRAC, ROUGHNESS
      REAL CALPHA, ALPHA, FORWARD, BACKWARD, i, e, hapke_emue
      REAL H_function
      REAL hapke_imue, imue, emue, H_imue, H_emue, S, S_function
      LOGICAL flag

      CALPHA = MU * MUP - (1.-MU**2)**.5 * (1.-MUP**2)**.5
     &         * COS( DPHI )

      ALPHA = ACOS( CALPHA )

      FORWARD = (1. - ASYM**2.) / (1. + 2. * ASYM * COS(ALPHA) +
     &           ASYM**2.)**1.5
      BACKWARD = (1. - ASYM**2.) / (1. - 2. * ASYM * COS(ALPHA) +
     &           ASYM**2.)**1.5
      P = FRAC * FORWARD + (1-FRAC)*BACKWARD
      B     = B0 * HH / ( HH + TAN( ALPHA/2.) )

      flag = .false.
      i = ACOS(MU)
      e = ACOS(MUP)
      imue = Hapke_imue(i, e, ALPHA, ROUGHNESS)
      emue = Hapke_emue(i, e, ALPHA, ROUGHNESS)
      H_imue = H_function(imue, w, flag)
      H_emue = H_function(emue, w, flag)
      S = S_function(i, e, ALPHA, ROUGHNESS)

      BRDF = W / (4.*PI * MU) * (imue / (imue + emue)) *
     &         ((1.0 + B) * p + H_imue * H_emue - 1.0) * S

      END
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c subroutines written by Frank Seelos, ported from f90 to f77 by M.
c Wolff (that fiend!)
c
c history:
c 2005/07/27 (mjw):  changed "END FUNCTION" syntax to just "END"
c

      REAL FUNCTION H_function(x, w, H_approx)

cFUNCTION:
c	H_function
c
cCALLED BY:
c	HapkeBDREF
c
cCALLS:
c	Hapke_gamma
c	Hapke_r0 (conditionally)
c
cINPUT PARAMETERS:
c	x : the cosine of either the incidence or emission angle depending on the calling
c		circumstance
c	w : single scattering albedo
c
cPURPOSE:
c	H_function is an approximation to Chandreskehar H-function which is fundamental to the
c	calculation of the bidirectional reflectance of a semiinfinite medium of isotropic scatterers.
c
cREFERENCE:
c	Hapke (1993); Eqn. 8.55; p. 212

      IMPLICIT NONE
      REAL Hapke_gamma
      REAL Hapke_r0
      LOGICAL H_approx

      REAL x, w
      REAL gamma, r0

      gamma = Hapke_gamma(w)

      if (H_approx .EQV. .FALSE.) then
         H_function = (1.0 + 2.0 * x) / (1.0 + 2.0 * x * gamma)
      else
         r0 = Hapke_r0(gamma)
         H_function  = 1.0 / (1.0 - (1.0 - gamma) * x *
     &     (r0 + (1.0 - 0.5 * r0 - r0 * x) * alog((1.0 + x) / x)))

      end if

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION B_function(g, h, B_approx)

cFUNCTION:
c	B_function
c
cCALLED BY:
c	HapkeBDREF
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle
c	h : compaction parameter
c
cPURPOSE:
c	The opposition effect function (B_function) calculates the effect of shadow hiding on the
c	bidirectional reflectance function
c
cREFERENCE:
c	Hapke (1993); Eqn. 8.81; p. 224

      IMPLICIT NONE

      REAL  pi

      REAL  Hapke_y, ERF
      REAL  y

      REAL  g, h
      LOGICAL  B_approx

      pi = 2.0 * asin(1.0)

c	write (*,*), 'B_approx_flag: ', B_approx_flag

      if (B_approx .EQV. .FALSE.) then
         B_function = 1.0 / (1.0 + 1.0 / h * tan(g / 2.0))
      else
         y = Hapke_y(g, h)
         B_function = sqrt((4.0 * pi) / y) * exp(1.0 / y) *
     &        (ERF(sqrt(4.0 / y)) - ERF(sqrt(1.0 / y))) +
     &        exp(-3.0 / y) - 1.0
      endif

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION S_function(i, e, psi, theta_bar)

cFUNCTION:
c	S_function
c
cCALLED BY:
c	HapkeBDREF
c
cCALLS:
c	Hapke_mue0
c	Hapke_imue
c	Hapke_emue
c	Hapke_chi
c	Hapke_fpsi
c
cINPUT PARAMETERS:
c	i : incidence angle
c	e : emission angle
c	psi : difference in azimuth angle between incident and emergent rays
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	The shadowing function (S_function) calculates the effect of macroscopic
c	roughness on the bidirectional reflectance function
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.50 & 12.54; p. 345

      IMPLICIT NONE

      REAL Hapke_mue0, Hapke_imue, Hapke_emue, Hapke_chi, Hapke_fpsi
      REAL  i, e, psi, theta_bar
      REAL imu, emu, imue0, emue0, imue, emue, S

      imu = cos(i)
      emu = cos(e)

      imue0 = Hapke_mue0(i, theta_bar)
      emue0 = Hapke_mue0(e, theta_bar)

      imue = Hapke_imue(i, e, psi, theta_bar)
      emue = Hapke_emue(i, e, psi, theta_bar)

      if (i .le. e) then
         S = (emue / emue0) * (imu / imue0) *
     &        (Hapke_chi(theta_bar) / (1.0 - Hapke_fpsi(psi) +
     &        Hapke_fpsi(psi) * Hapke_chi(theta_bar) * (imu / imue0)))

      else
         S = (emue / emue0) * (imu / imue0) *
     &        (Hapke_chi(theta_bar) / (1.0 - Hapke_fpsi(psi) +
     &        Hapke_fpsi(psi) * Hapke_chi(theta_bar) * (emu / emue0)))

      endif

      S_function = S

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_imue(i, e, psi, theta_bar)

cFUNCTION:
c	Hapke_imue
c
cCALLED BY:
c	S_function
c
cCALLS:
c	Hapke_chi
c	Hapke_E1
c	Hapke_E2
c
cINPUT PARAMETERS:
c	i : incidence angle
c	e : emission angle
c	psi : difference in azimuth angle between incident and emergent rays
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_imue is the cosine of the effective incidence angle when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.46 & 12.52; p. 344 & 345

      IMPLICIT NONE

      REAL  pi
      REAL Hapke_chi, Hapke_E1, Hapke_E2
      REAL  i, e, psi, theta_bar
      REAL imue

      pi = 2.0 * asin(1.0)

      if (i .le. e) then

c		write (*,*), 'IMUE'
c		write (*,*), i, e, psi, theta_bar
c		write (*,*), Hapke_chi(theta_bar)
c		write (*,*), Hapke_E1(e, theta_bar), Hapke_E1(i, theta_bar)
c		write (*,*), Hapke_E2(e, theta_bar), Hapke_E2(i, theta_bar)
c		write (*,*)

         imue = Hapke_chi(theta_bar) * (cos(i) + sin(i) *
     &        tan(theta_bar) *	((cos(psi) * Hapke_E2(e, theta_bar)
     &        + (sin(psi/2.0))**2.0 * Hapke_E2(i, theta_bar)) /
     &        (2.0 - Hapke_E1(e, theta_bar) - (psi/pi) *
     &        Hapke_E1(i, theta_bar))))
      else

         imue = Hapke_chi(theta_bar) * (cos(i) + sin(i) *
     &        tan(theta_bar) * ((Hapke_E2(i, theta_bar) -
     &        (sin(psi/2.0))**2.0 * Hapke_E2(e, theta_bar)) /
     &        (2.0 - Hapke_E1(i, theta_bar) - (psi/pi) *
     &        Hapke_E1(e, theta_bar))))
      endif

      Hapke_imue = imue

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_emue(i, e, psi, theta_bar)

cFUNCTION:
c	Hapke_emue
c
cCALLED BY:
c	S_function
c
cCALLS:
c	Hapke_chi
c	Hapke_E1
c	Hapke_E2
c
cINPUT PARAMETERS:
c	i : incidence angle
c	e : emission angle
c	psi : difference in azimuth angle between incident and emergent rays
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_emue is the cosine of the effective emission angle when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.47 & 12.53; p. 344 & 345

      IMPLICIT NONE

      REAL pi
      REAL Hapke_chi, Hapke_E1, Hapke_E2
      REAL  i, e, psi, theta_bar
      REAL  emue

      pi = 2.0 * asin(1.0)

      if (i .le. e) then
         emue = Hapke_chi(theta_bar) * (cos(e) + sin(e) *
     &        tan(theta_bar) * ((Hapke_E2(e, theta_bar) -
     &        (sin(psi/2.0))**2.0 * Hapke_E2(i, theta_bar)) /
     &        (2.0 - Hapke_E1(e, theta_bar) - (psi/pi) *
     &        Hapke_E1(i, theta_bar))))
      else
         emue = Hapke_chi(theta_bar) * (cos(e) + sin(e) *
     &        tan(theta_bar) * ((cos(psi) * Hapke_E2(i, theta_bar) +
     &        (sin(psi/2.0))**2.0 * Hapke_E2(e, theta_bar)) /
     &        (2.0 - Hapke_E1(i, theta_bar) - (psi/pi) *
     &        Hapke_E1(e, theta_bar))))

      endif

      Hapke_emue = emue

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_mue0(theta, theta_bar)

cFUNCTION:
c	Hapke_mue0
c
cCALLED BY:
c	S_function
c
cCALLS:
c	Hapke_chi
c	Hapke_E1
c	Hapke_E2
c
cINPUT PARAMETERS:
c	theta : incidence or emission angle (i or e) depending on calling circumstance
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_mue0 is the cosine of the effective incidence or emission angle when psi EQ 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.48 & 12.49; p. 344

      IMPLICIT NONE
      REAL Hapke_chi, Hapke_E1, Hapke_E2
      REAL  theta, theta_bar

      Hapke_mue0 = Hapke_chi(theta_bar) * (cos(theta) + sin(theta)
     &     * tan(theta_bar) * Hapke_E2(theta, theta_bar) /
     &     (2.0 - Hapke_E1(theta, theta_bar)))

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_y(g, h)

      IMPLICIT NONE

      REAL  g, h

      Hapke_y = tan(g/2.0) / h
      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_r0(gamma)

cFUNCTION:
c	Hapke_r0
c
cCALLED BY:
c	H_function (conditionally)
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	gamma : albedo factor
c
cPURPOSE:
c	Hapke_r0 (diffusive reflectance) is used in the more exact approximation to the
c	Chandreskehar H-function
c
cREFERENCE:
c	Hapke (1993); Eqn. 8.25; p. 196

      IMPLICIT NONE

      REAL  gamma

      Hapke_r0 = (1.0 - gamma) / (1.0 + gamma)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_gamma(w)

cFUNCTION:
c	Hapke_gamma
c
cCALLED BY:
c	H_function
c	B_function
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	w : single scattering albedo
c
cPURPOSE:
c	Hapke_gamma (albedo factor) is a component in the calculation of the Chandrasekhar
c	H-functions and the contribution of the opposition effect
c
cREFERENCE:
c	Hapke (1993); Eqn. 8.22b; p. 195

      IMPLICIT NONE

      REAL  w

      Hapke_gamma = sqrt(1.0 - w)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_chi(theta_bar)

cFUNCTION:
c	Hapke_chi
c
cCALLED BY:
c	S_function
c	Hapke_imue
c	Hapke_emue
c	Hapke_mue0
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_chi is a component in the calculation of the shadowing function and the
c	cosines of the effective incidence and emission angles when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.45a; p. 344

      IMPLICIT NONE

      REAL  pi

      REAL  theta_bar

      pi = 2.0 * asin(1.0)

      Hapke_chi = 1.0 / sqrt(1.0 + pi * tan(theta_bar)**2.0)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_fpsi(psi)

cFUNCTION:
c	Hapke_fpsi
c
cCALLED BY:
c	S_function
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	psi : difference in azimuth angle between incident and emergent rays
c
cPURPOSE:
c	Hapke_fpsi is a component in the calculation of the shadowing function when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.51; p. 345

      IMPLICIT NONE
      REAL pi
      REAL  psi

      pi = 2.0 * asin(1.0)

      if (psi .eq. pi) then
         Hapke_fpsi = 0.0
      else
         Hapke_fpsi = exp(-2.0 * tan(psi / 2.0))
      endif

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_E1(x, theta_bar)

cFUNCTION:
c	Hapke_E1
c
cCALLED BY:
c	Hapke_imue
c	Hapke_emue
c	Hapke_mue0
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	x : incidence or emission angle (i or e) depending on input geometry
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_E1 is a component in the calculation of the cosines of the effective incidence
c	and emission angles when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.45b; p. 344

      IMPLICIT NONE
      REAL  pi
      REAL  x, theta_bar

      pi = 2.0 * asin(1.0)

      if (x .eq. 0.0) then
         Hapke_E1 = 0.0
      else
         Hapke_E1 = exp(-2.0 / pi * 1.0/tan(theta_bar) * 1.0/tan(x))
      endif

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION Hapke_E2(x, theta_bar)

cFUNCTION:
c	Hapke_E2
c
cCALLED BY:
c	Hapke_imue
c	Hapke_emue
c	Hapke_mue0
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	x : incidence or emission angle (i or e) depending on input geometry
c	theta_bar : macroscopic roughness parameter (mean slope angle)
c
cPURPOSE:
c	Hapke_E2 is a component in the calculation of the cosines of the effective incidence
c	and emission angles when theta_bar NE 0.0
c
cREFERENCE:
c	Hapke (1993); Eqn. 12.45c; p. 344

      IMPLICIT NONE
      REAL  pi

      REAL x, theta_bar
      pi = 2.0 * asin(1.0)

      if (x .eq. 0.0) then
         Hapke_E2 = 0.0
      else
         Hapke_E2 = exp(-1.0 / pi * (1.0/tan(theta_bar))**2.0 *
     &        (1.0/tan(x))**2.0)
      endif

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_isotropic()
c
cFUNCTION:
c	phf_isotropic
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	NONE
c
cPURPOSE:
c	Isotropic phase function
c
cREFERENCE:

      IMPLICIT NONE

      phf_isotropic = 1.0

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_aniso_neg(g)
c
cFUNCTION:
c	phf_aniso_neg
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle
c
cPURPOSE:
c	Calculate anisotropic phase function [1 - cos(g)]
c
cREFERENCE:
c	Hapke (1993); p. 214

      IMPLICIT NONE

      REAL g

      phf_aniso_neg = 1.0 - cos(g)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_aniso_pos(g)
c
cFUNCTION:
c	phf_aniso_pos
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle
c
cPURPOSE:
c	Calculate anisotropic phase function [1 + cos(g)]
c
cREFERENCE:
c	Hapke (1993); p. 214

      IMPLICIT NONE

      REAL g

      phf_aniso_pos = 1.0 + cos(g)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_rayleigh(g)
c
cFUNCTION:
c	phf_rayleigh
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle
c
cPURPOSE:
c	Calculate Rayleigh phase function
c
cREFERENCE:
c

      IMPLICIT NONE

      REAL g

      phf_rayleigh = (3.0/4.0) * (1.0 + (cos(g))**2.0)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_hg1(g, a)
c
cFUNCTION:
c	phf_hg1
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle (radians)
c	a : asymmetry parameter [-1,1];
c		Negative is back; Positive is forward.
c
cPURPOSE:
c	Calculate one parameter Henyey-Greenstein phase function
c
cREFERENCE:
c

      IMPLICIT NONE

      REAL g, a

      phf_hg1 = (1.0 - a**2.0) / ((1.0 + 2.0 * a * cos(g)
     $     + a**2.0)**1.5)

      RETURN

      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_hg2(g, a, f)
c
cFUNCTION:
c	phf_hg2
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g : phase angle (radians)
c	a : asymmetry parameter [0,1]
c	f : forward fraction [0,1]
c
cPURPOSE:
c	Calculate two parameter Henyey-Greenstein phase function
c
cREFERENCE:
c

      IMPLICIT NONE

      REAL g, a, f
      REAL forward, backward
      REAL phf_hg1

      forward = phf_hg1(g, a)
      backward = phf_hg1(g, -1.0 * a)

      phf_hg2 = f * forward + (1.0 - f) * backward

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c

      REAL FUNCTION phf_hg3(g, af, ab, f)
c
cFUNCTION:
c	phf_hg3
c
cCALLED BY:
c	HapkeBDREFPhaseFunctions
c
cCALLS:
c	NONE
c
cINPUT PARAMETERS:
c	g  : phase_angle (radians)
c	af : forward asymmetry parameter [0,1]
c	ab : backward asymmetry parameter [-1,0]
c	f  : forward fraction [0,1]
c
cPURPOSE:
c	Calculate three parameter Henyey-Greenstein phase function
c
cREFERENCE:
c

      IMPLICIT NONE

      REAL g, af, ab, f
      REAL phf_hg1
      REAL forward, backward

      forward = phf_hg1(g, af)
      backward = phf_hg1(g, ab)

      phf_hg3 = f * forward + (1.0 - f) * backward

      RETURN
      END

c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c
c---------------------------------------------------------------------------c


      SUBROUTINE STRP11
C
C     PHASE 1 STRESS DATA RECOVERY FOR CTRPLT1 - HIGHER ORDER PLATE
C     ELEMENT
C
C     OUTPUTS FROM THIS PHASE FOR USE IN PHASE II ARE THE FOLLOWING
C
C     1) ELEMENT ID              WORDS    1     STORAGE IN PH1OUT  1
C     2) SIX SILS                WORDS    6                      2-7
C     3) BENDING THICKNESSES     WORDS    3                      8-10
C     4) STRESS POINTS           WORDS    8                     11-18
C     5) 4 NOS. 6 5X6 S MATRICES WORDS    720                   19-738
C     6) 3X1 S SUB T MATRIX      WORDS    3                    739-741
C
C     ECPT ENTRIES
C     AS IN STIFFNESS ROUTINE KTRPL1
C
      LOGICAL          NOTS
      REAL             J11,J12,J22,NSM,IVECT,JVECT,KVECT
      DOUBLE PRECISION DETERM
      DIMENSION        NAME(2),INDEX(20,3),ICS(6),NL(6),Q(6,6),IND(6,3),
     1                 EMOD(9),XC(6),YC(6),ZC(6),QQQ(20,20),QQQINV(360),
     2                 TS6(40),TS7(59),IEST(42),IVECT(3),JVECT(3),
     3                 KVECT(3),E(18),V1(3),V2(3),V3(3),E1(18),
     4                 PH1BEN(9),PH1SHR(6),PH2(18),PH3(12),PH4(90),
     5                 TRANS(9),BALOTR(36),D(9),DPH1(9),G(4),GPH1(6),
     6                 NPH1OU(990)
      COMMON /SDR2X5/  EST(100),PH1OUT(990),FORVEC(24),
     1                 X,Y,Z,DISTA,DISTB,DISTC,A1,A2,A3,B1,B2,B3,
     2                 QQQINV,TS6,TS7,PH2,PH3,PH4,Q,E,E1,TRANS,BALOTR
C
C     INPUT AND OUTPUT BLOCKS FOR SUBROUTINE MAT
C
      COMMON /MATIN /  MATID,MATFLG,ELTEMP,PLA34,SINTH,COSTH
      COMMON /MATOUT/  EM(6),RHOY,ALF(3),TREF,GSUBE,SIGTY,SIGCY,SIGSY,
     1                 RJ11,RJ12,RJ22
C
C
C     EQUIVALENCE IECPT WITH ECPT IN COMMON BLOCK /SMA1ET/ SINCE ECPT IS
C     A MIXED INTEGER AND REAL ARRAY
C
      EQUIVALENCE     (A,DISTA), (B,DISTB), (C,DISTC),
     1                (V1(1),EST(19)),(V2(1),EST(23)),(V3(1),EST(27)),
     2                (IEST(1),EST(1)),
     3                (D11,EM(1)),(D12,EM(2)), (D13,EM(3)),
     4                (D22,EM(4)),(D23,EM(5)), (D33,EM(6))
      EQUIVALENCE     (NPH1OU(1),PH1OUT(1))
      EQUIVALENCE     (PH1OUT(401),INDEX(1,1),IND(1,1))
      EQUIVALENCE     (PH1OUT(1),QQQ(1,1))
      DATA  DEGRA  /  0.0174532925            /
      DATA  BLANK  ,  NAME / 4H    , 4HCTRP, 4HLT1   /
C
      NOTS  =.FALSE.
      IDELE = IEST(1)
      DO 109 I = 1,6
      NL(I) = IEST(I+1)
  109 CONTINUE
      THETAM = EST(8)
      MATID1 = IEST(9)
      TMEM1  = (EST(10)*12.0)**0.333333333333
      TMEM3  = (EST(11)*12.0)**0.333333333333
      TMEM5  = (EST(12)*12.0)**0.333333333333
      MATID2 = IEST(13)
      TSHR1  = EST(14)
      TSHR3  = EST(15)
      TSHR5  = EST(16)
      NSM    = EST(17)
      J      = 0
      DO 120 I = 24,44,4
      J      = J + 1
      ICS(J) = IEST(I)
      XC(J)  = EST(I+1)
      YC(J)  = EST(I+2)
      ZC(J)  = EST(I+3)
  120 CONTINUE
C
C     IF TMEM3 OR TMEM5 IS ZERO OR BLANK, THEY WILL BE SET EQUAL TO
C     TMEM1
C     SO ALSO FOR TEMP3 OR TEMP5
C
      IF (TMEM3.EQ.0.0 .OR. TMEM3.EQ.BLANK) TMEM3 = TMEM1
      IF (TMEM5.EQ.0.0 .OR. TMEM5.EQ.BLANK) TMEM5 = TMEM1
      IF (TSHR3.EQ.0.0 .OR. TSHR3.EQ.BLANK) TSHR3 = TSHR1
      IF (TSHR5.EQ.0.0 .OR. TSHR5.EQ.BLANK) TSHR5 = TSHR1
      IF (TSHR1 .EQ. 0.0) NOTS = .TRUE.
      ELTEMP = EST(48)
      THETA1 = THETAM*DEGRA
      SINTH  = SIN(THETA1)
      COSTH  = COS(THETA1)
      IF (ABS(SINTH) .LE. 1.0E-06) SINTH = 0.0
C
C     EVALUATE MATERIAL PROPERTIES
C
      MATFLG = 2
      MATID  = MATID1
      CALL MAT (IDELE)
C
      EMOD(1) = D11
      EMOD(2) = D12
      EMOD(3) = D13
      EMOD(4) = D12
      EMOD(5) = D22
      EMOD(6) = D23
      EMOD(7) = D13
      EMOD(8) = D23
      EMOD(9) = D33
      MATID   = MATID2
      MATFLG  = 3
      J11     = 0.0
      J12     = 0.0
      J22     = 0.0
      IF (NOTS) GO TO 146
      CALL MAT (IDELE)
  146 CONTINUE
C
C     CALCULATIONS FOR THE TRIANGLE
C
      CALL TRIF (XC,YC,ZC,IVECT,JVECT,KVECT,A,B,C,IEST(1),NAME)
      CALL AF (F,1,A,B,C,A1,A2,A3,TMEM1,TMEM3,TMEM5,1)
      CALL AF (F,1,A,B,C,B1,B2,B3,TSHR1,TSHR3,TSHR5,1)
C
C     FILL E-MATRIX
C
      DO 177 I = 1,18
  177 E( I) = 0.0
      E( 1) = KVECT(1)
      E( 4) = KVECT(2)
      E( 7) = KVECT(3)
      E(11) = IVECT(1)
      E(14) = IVECT(2)
      E(17) = IVECT(3)
      E(12) = JVECT(1)
      E(15) = JVECT(2)
      E(18) = JVECT(3)
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
C
C     CALCULATIONS FOR QMATRIX (QQQ) AND ITS INVERSE
C
      DO 110 I = 1,20
      DO 110 J = 1,20
  110 QQQ(I,J) = 0.0
      DO 115 I = 1,6
      I1 = (I-1)*3 + 1
      I2 = (I-1)*3 + 2
      I3 = (I-1)*3 + 3
      QQQ(I1, 1) = 1.0
      QQQ(I1, 2) = XC(I)
      QQQ(I1, 3) = YC(I)
      QQQ(I1, 4) = XC(I)*XC(I)
      QQQ(I1, 5) = XC(I)*YC(I)
      QQQ(I1, 6) = YC(I)*YC(I)
      QQQ(I1, 7) = QQQ(I1, 4)*XC(I)
      QQQ(I1, 8) = QQQ(I1, 4)*YC(I)
      QQQ(I1, 9) = QQQ(I1, 5)*YC(I)
      QQQ(I1,10) = QQQ(I1, 6)*YC(I)
      QQQ(I1,11) = QQQ(I1, 7)*XC(I)
      QQQ(I1,12) = QQQ(I1, 7)*YC(I)
      QQQ(I1,13) = QQQ(I1, 8)*YC(I)
      QQQ(I1,14) = QQQ(I1, 9)*YC(I)
      QQQ(I1,15) = QQQ(I1,10)*YC(I)
      QQQ(I1,16) = QQQ(I1,11)*XC(I)
      QQQ(I1,17) = QQQ(I1,12)*YC(I)
      QQQ(I1,18) = QQQ(I1,13)*YC(I)
      QQQ(I1,19) = QQQ(I1,14)*YC(I)
      QQQ(I1,20) = QQQ(I1,15)*YC(I)
      QQQ(I2, 3) = 1.0
      QQQ(I2, 5) = XC(I)
      QQQ(I2, 6) = YC(I)*2.0
      QQQ(I2, 8) = QQQ(I1, 4)
      QQQ(I2, 9) = QQQ(I1, 5)*2.0
      QQQ(I2,10) = QQQ(I1, 6)*3.0
      QQQ(I2,12) = QQQ(I1, 7)
      QQQ(I2,13) = QQQ(I1, 8)*2.0
      QQQ(I2,14) = QQQ(I1, 9)*3.0
      QQQ(I2,15) = QQQ(I1,10)*4.0
      QQQ(I2,17) = QQQ(I1,12)*2.0
      QQQ(I2,18) = QQQ(I1,13)*3.0
      QQQ(I2,19) = QQQ(I1,14)*4.0
      QQQ(I2,20) = QQQ(I1,15)*5.0
      QQQ(I3, 2) =-1.0
      QQQ(I3, 4) =-2.0*XC(I)
      QQQ(I3, 5) =-YC(I)
      QQQ(I3, 7) =-QQQ(I1, 4)*3.0
      QQQ(I3, 8) =-QQQ(I1, 5)*2.0
      QQQ(I3, 9) =-QQQ(I1, 6)
      QQQ(I3,11) =-QQQ(I1, 7)*4.0
      QQQ(I3,12) =-QQQ(I1, 8)*3.0
      QQQ(I3,13) =-QQQ(I1, 9)*2.0
      QQQ(I3,14) =-QQQ(I1,10)
      QQQ(I3,16) =-QQQ(I1,11)*5.0
      QQQ(I3,17) =-QQQ(I1,13)*3.0
      QQQ(I3,18) =-QQQ(I1,14)*2.0
      QQQ(I3,19) =-QQQ(I1,15)
C
C     IF NO TRANSVERSE SHEAR GO TO 113
C
      IF (NOTS) GO TO 1137
      X = XC(I)
      Y = YC(I)
      CALL STRPTS (TS6,NOTS)
      DO 113 JJ = 1,20
      QQQ(I2,JJ) = QQQ(I2,JJ) - TS6(20+JJ)
      QQQ(I3,JJ) = QQQ(I3,JJ) + TS6(   JJ)
  113 CONTINUE
 1137 CONTINUE
  115 CONTINUE
      QQQ(19,16) = 5.0*A**4*C
      QQQ(19,17) = 3.0*A**2*C**3 - 2.0*A**4*C
      QQQ(19,18) =-2.0*A*C**4 + 3.0*A**3*C**2
      QQQ(19,19) = C**5 - 4.0*A**2*C**3
      QQQ(19,20) = 5.0*A*C**4
      QQQ(20,16) = 5.0*B**4*C
      QQQ(20,17) = 3.0*B**2*C**3 - 2.0*B**4*C
      QQQ(20,18) = 2.0*B*C**4 - 3.0*B**3*C**2
      QQQ(20,19) = C**5 - 4.0*B**2*C**3
      QQQ(20,20) =-5.0*B*C**4
C
C     FOURTH ARGUMENT IS A DUMMY LOCATION FOR INVERSE AND HENCE TS1(1)
C     IS U
C
      CALL INVERS (20,QQQ,20,TS6(1),0,DETERM,ISING,INDEX)
C
C     ISING EQUAL TO 2 IMPLIES THAT QQQ IS SINGULAR
C
C     FIRST 18 COLUMNS OF QQQ INVERSE IS THE QQQINV FOR USE IN STIFFNESS
C     MATRIX CALCULATIONS
C
      DO 152 I = 1,20
      DO 152 J = 1,18
      IJ = (I-1)*18 + J
      QQQINV(IJ) = QQQ(I,J)
  152 CONTINUE
      DO 154 I = 1,36
  154 BALOTR(I) = 0.0
C
      DO 102 I = 1,7
      PH1OUT(I) = EST(I)
  102 CONTINUE
      PH1OUT( 8) = TMEM1
      PH1OUT( 9) = TMEM3
      PH1OUT(10) = TMEM5
      PH1OUT(11) = EST(18)
      PH1OUT(12) = EST(19)
      PH1OUT(13) = EST(20)
      PH1OUT(14) = EST(21)
      PH1OUT(15) = EST(22)
      PH1OUT(16) = EST(23)
      DO 700 JJ = 1,4
      JJ1 = JJ*2 - 1
      IF (JJ .NE. 4) X = XC(JJ1)
      IF (JJ .NE. 4) Y = YC(JJ1)
      IF (JJ .EQ. 4) X = (XC(1)+XC(3)+XC(5))/3.0
      IF (JJ .EQ. 4) Y = (YC(1)+YC(3)+YC(5))/3.0
      IF (JJ .EQ. 4) PH1OUT(17) = (A1+A2*X+A3*Y)/2.0
      IF( JJ .EQ. 4) PH1OUT(18) = -PH1OUT(17)
      DO 105 I = 1,60
      TS7(I) = 0.0
  105 CONTINUE
      AI = PH1OUT(7+JJ)**3/12.0
      IF (JJ .EQ. 4) AI = PH1OUT(17)**3/1.5
      DO 107 I = 1,9
  107 D(I) = EMOD(I)*AI
      X2  = X*X
      XY  = X*Y
      Y2  = Y*Y
      X3  = X2*X
      X2Y = X2*Y
      XY2 = X*Y2
      Y3  = Y2*Y
      TS7( 4) = 2.0
      TS7( 7) = 6.0*X
      TS7( 8) = 2.0*Y
      TS7(11) = 12.0*X2
      TS7(12) = 6.0*XY
      TS7(13) = 2.0*Y2
      TS7(16) = 20.0*X3
      TS7(17) = 6.0*XY2
      TS7(18) = 2.0*Y3
      TS7(26) = 2.0
      TS7(29) = 2.0*X
      TS7(30) = 6.0*Y
      TS7(33) = 2.0*X2
      TS7(34) = TS7(12)
      TS7(35) = 12.0*Y2
      TS7(37) = 2.0*X3
      TS7(38) = 6.0*X2Y
      TS7(39) = 12.0*XY2
      TS7(40) = 20.0*Y3
      TS7(45) = 2.0
      TS7(48) = 4.0*X
      TS7(49) = 4.0*Y
      TS7(52) = 6.0*X2
      TS7(53) = 8.0*XY
      TS7(54) = 6.0*Y2
      TS7(57) = 12.0*X2Y
      TS7(58) = TS7(39)
      TS7(59) = 8.0*Y3
      CALL GMMATS (TS7,3,20,0, QQQINV,20,18,0, PH4(1))
      CALL STRPTS (TS6,NOTS)
      CALL GMMATS (TS6,2,20,0, QQQINV,20,18,0, PH4(55))
      DO 600 II = 1,6
      IF (ICS(II) .EQ. 0) GO TO 130
      J = 4*II + 20
      CALL TRANSS (IEST(J),TRANS)
      DO 124 J = 1,3
      L = 6*(J-1) + 1
      M = 3*(J-1) + 1
      BALOTR(L   ) = TRANS(M  )
      BALOTR(L+ 1) = TRANS(M+1)
      BALOTR(L+ 2) = TRANS(M+2)
      BALOTR(L+21) = TRANS(M  )
      BALOTR(L+22) = TRANS(M+1)
      BALOTR(L+23) = TRANS(M+2)
  124 CONTINUE
      CALL GMMATS (E,6,3,+1, BALOTR,6,6,0, E1)
      GO TO 133
  130 CONTINUE
      DO 132 I = 1,3
      DO 132 J = 1,6
      I1 = (I-1)*6 + J
      J1 = (J-1)*3 + I
      E1(I1) = E(J1)
  132 CONTINUE
  133 CONTINUE
      KZ = (II-1)*3 + 1
      PH1BEN(1) = PH4(KZ   )
      PH1BEN(2) = PH4(KZ+ 1)
      PH1BEN(3) = PH4(KZ+ 2)
      PH1BEN(4) = PH4(KZ+18)
      PH1BEN(5) = PH4(KZ+19)
      PH1BEN(6) = PH4(KZ+20)
      PH1BEN(7) = PH4(KZ+36)
      PH1BEN(8) = PH4(KZ+37)
      PH1BEN(9) = PH4(KZ+38)
      CALL GMMATS (D,3,3,0, PH1BEN,3,3,0, DPH1)
      CALL GMMATS (DPH1,3,3,0, E1,3,6,0, PH2)
      MZ = (II-1)*3 + 55
      PH1SHR(1) = PH4(MZ   )
      PH1SHR(2) = PH4(MZ+ 1)
      PH1SHR(3) = PH4(MZ+ 2)
      PH1SHR(4) = PH4(MZ+18)
      PH1SHR(5) = PH4(MZ+19)
      PH1SHR(6) = PH4(MZ+20)
      IF (NOTS) GO TO 166
      THK  = B1 + B2*X + B3*Y
      G(1) = EM(6)*THK
      G(2) = 0.0
      G(3) = 0.0
      G(4) = G(1)
      CALL GMMATS (G,2,2,0, PH1SHR,2,3,0, GPH1)
      GO TO 168
  166 CONTINUE
      GPH1(1) = PH1SHR(1)
      GPH1(2) = PH1SHR(2)
      GPH1(3) = PH1SHR(3)
      GPH1(4) = PH1SHR(4)
      GPH1(5) = PH1SHR(5)
      GPH1(6) = PH1SHR(6)
  168 CONTINUE
      CALL GMMATS (GPH1,2,3,0, E1,3,6,0, PH3)
      DO 148 I = 1,3
      DO 148 J = 1,6
      I1 = (I-1)*6 + J
      I2 = I1 + 18
      J1 = (II-1)*30 + (JJ-1)*180 + I1 + 18
      J2 = J1 + 18
      PH1OUT(J1) = PH2(I1)
      IF (I .NE. 3) PH1OUT(J2) = PH3(I1)
  148 CONTINUE
  600 CONTINUE
      JJ1 = (JJ-1)*3 + 1
      CALL GMMATS (D,3,3,0, ALF,3,1,0, PH1OUT(738+JJ1))
  700 CONTINUE
      RETURN
      END


subroutine  MOM (Pot_S,DT,MONCE)
  use simsphere_mod
  implicit none

! **  Subroutine MOM calculates the momentum and thermodynamic eqs. in the
! **  lowest 500m of the atmosphere and produces profiles of the U & V
! **  components, humidity and temperature at 50m intervals to couple
! **  surface and mixing layers.

  real :: CR(46), OK(46), BX(46), WIND(46), WGEOS(46)
  real :: B(46), DUW(46), KRAD, DVW(46), DTW(46), RI(46)
  real :: DZ, SB, Pot_S, UIF, UIF2, RC, BX1
  real :: DU, DV, ABDU, ABDV, X1, OKMAX
  integer :: IMAX, IMAX1, DT, MONCE
  integer :: I

!      INCLUDE 'modvars.h'

  KRAD = 0.75

  OKMAX = 1.0
  X1 = 0.0

  IF ( MONCE .EQ. 0 ) THEN

! **  Perform initialisations.
! **  UIF,UIF2 are correction factors to account for 1st layer not being
! **  centred when the night SFL depth is below 50 m (ZA).
! **  This is not necessary at present as ZA = 50 m.

    DZ = 50.0
    SB = 784.0
!    IMAX = 50
    IMAX = size(bx)

    UIF = ( 2 * DZ / ZA ) - 1
    UIF2 = DZ / ( 2 * DZ - ZA )

! **  Set up constants for the Richardson number calculation.

    RC = ( GRAV * DZ ) / OTEMP
    IMAX1 = IMAX - 1

! **  Set values of Critical Richardson # and turbulent diffusivities to
! **  a nominal value and smooth the temperature profile.

    do I = 1 , IMAX1
      CR(I) = 0.001
      OK(I) = 0.01
      T(I) = ( T(I) + T(I+1) ) / 2
    end do

! **  Make the diffusion coefficient (BX1) for radiation unitless.

    BX1 = KRAD * DT / ( DZ**2 )
    MONCE = 2

  END IF

! **  Calculate bulk parameters .... Windspeed, Geostrophic Windspeed
! **  and Critical Richardson number at all levels.

!    do while (.not. eq(xmod,0.0))
  100 do I = 1 , IMAX
!      do I = 1 , IMAX
        WIND(I) = SQRT( U(I)**2 + V(I)**2 )
        WGEOS(I) = SQRT( UG(I)**2 + VG(I)**2 )
        CR(I) = ( EXP( -0.2129 * WGEOS(I) ) * 0.5542 ) + 0.2
      end do

  ! **  Take derivatives of U and V and their absolute value.  Set a
  ! **  minimum value for the derivatives.  Calculate the local Richardson
  ! **  number using the expression for Si and our constant (g/  ).
  ! **  Next, find the values for the eddy exchange coefficients (Kh & Km);
  ! **  note ... assumed to be the same in the stable nocturnal boundary
  ! **  layer. (SB = l).  Smooth and set the non-dimensional forms for
  ! **  momentum (B) and heat (BX).

    do I = 2 , IMAX
      DU = U(I) - U(I-1)
      DV = V(I) - V(I-1)
      ABDU = ABS(DU)
      ABDV = ABS(DV)
      IF ( ABDU .LT. 0.001) DU = 0.001
      IF ( ABDV .LT. 0.001) DV = 0.001
      RI(I) = RC * ( T(I) - T(I-1) ) / ( (DU**2) + (DV**2) )
      OK(I) = SB * ( ( CR(I) - RI(I) ) / CR(I) ) * ( SQRT(DU**2 + DV**2 ) / DZ )
      OK(I) = OK(I) + 0.05 * OK(I-1)

      IF ( RI(I) .GE. CR(I) ) OK(I) = 0
      B(I) = ( OK(I) * DT ) / ( DZ**2 )
      BX(I) = ( (OK(I) + KRAD) * DT ) / ( DZ**2 )

      IF ( B(I) .GT. 0.25 ) B(I) = 0.25
      IF ( BX(I) .GT. 0.25 ) BX(I) = 0.25
      IF ( OK(I) .GT. OKMAX ) OKMAX = OK(I)

    end do

  ! **  Calculate the vertical profiles of temperature and wind from 50
  ! **  to 500 metres by integrating the U and V momentum equations and
  ! **  the thermodynamic equation.

    do I = 2 , IMAX1
      IF ( I .GT. 2) UIF2 = 1
      DUW(I) = B(I+1) * ( U(I+1) - U(I) ) - B(I) * ( U(I) -U(I-1) ) * UIF2
      DVW(I) = B(I+1) * ( V(I+1) - V(I) ) - B(I) * ( V(I) - V(I-1) ) * UIF2
      DTW(I) = BX(I+1) * ( T(I+1) - T(I) ) - BX(I) * ( T(I) - T(I-1) ) * UIF2
      QN(I) = QN(I) + ( B(I+1) * ( QN(I+1) - QN(I) ) - B(I) * ( QN(I) - QN(I-1) ) )
      U(I) = U(I) + CF * DT * ( V(I) - VG(I) ) + DUW(I)
      V(I) = V(I) - CF * DT * ( U(I) - UG(I) ) + DVW(I)
      T(I) = T(I) + DTW(I) - ( RAD - ADVGT ) * DT
    end do

  ! **  Integrate at top and bottom boundaries where no turbulent
  ! **  exchange exists and at the surface boundary condition.

    T(1) = T(1) + HEAT * DT / ( CP * DENS * ZA ) + BX(2) *                &
           ( T(2) - T(1) ) - ( RAD - ADVGT ) * DT
    T(1) = T(1) - BX1 * ( T(1) - Pot_S )
    U(1) = U(1) + CF * DT * ( V(1) - VG(1) ) + B(2) * ( U(2) - U(1) )     &
           -DT / DZ * USTAR**2 * U(1) / WIND(1) * UIF
    V(1) = V(1) - CF * DT * ( U(1) - UG(1) ) +B(2) * ( V(2) - V(1) )      &
           -DT / DZ * USTAR**2 * V(1) / WIND(1) * UIF
    QN(1) = QN(1) + ( B(2) * ( QN(2) - QN(1) ) + ( EVAP * DT / ( DENS * LE * DZ ) ) )
    U(IMAX) = U(IMAX) + CF * DT * ( V(IMAX) - VG(IMAX) ) - B (IMAX) *     &
              ( U(IMAX) - U(IMAX1) )
    V(IMAX) = V(IMAX) - CF * DT * ( U(IMAX) - UG(IMAX) ) - B (IMAX) *     &
              ( V(IMAX) - V(IMAX1) )
    T(IMAX) = T(IMAX) - BX(IMAX) * ( T(IMAX) - T(IMAX1) ) - ( RAD - ADVGT ) * DT

  ! **  Here we set QD = QN to be used in flux.

    QD(1) = QN(1)

  ! **  Increment the time control and cycle through twice (120s).

    X1 = X1 + 1
    XMOD = MOD ( X1 , 2.0 )
!  end do
  IF ( .not. eq(XMOD,0.0) ) GO TO 100

  AWIND =  ( SQRT(U(1)**2 + V(1)**2) )

! Fine Mesh

  do i=1,imax
    u_fine(i) = u(i)
    v_fine(i) = v(i)
    t_fine(i) = t(i)
    q_fine(i) = qn(i)
  end do

  return
end


module flow_mod

    use json_mod
    use json_xtnsn_mod
    use math_mod

    implicit none

    type flow

        real,dimension(:),allocatable :: v_inf ! Freestream velocity
        real :: M_inf ! Freestream Mach number
        real :: gamma ! Ratio of specific heats
        real :: U, U_inv ! Freestream velocity magnitude
        real :: B ! Compressibility scale factor
        real :: s ! Sign of 1-M^2; determines character of governing PDE (hyperbolic (s=-1) vs elliptic(s=1))
        real :: c ! Freestream speed of sound
        real :: mu, C_mu ! Mach angle
        real,dimension(3) :: c0 ! Compressibility axis (assumed in TriPan to be aligned with the freestream direction)
        real,dimension(3,3) :: C0_mat
        logical,dimension(3) :: sym_about ! Whether the flow condition is symmetric about any plane
        real,dimension(3,3) :: psi ! Dual metric matrix, expressed in global coords
        logical :: supersonic, incompressible
        real,dimension(3,3) :: A_g_to_c, A_c_to_s, A_g_to_s ! Coordinate transformation matrices

        contains

            procedure :: init => flow_init
            procedure :: C0_inner => flow_C0_inner
            procedure :: point_in_dod => flow_point_in_dod

    end type flow

contains

    subroutine flow_init(this, settings)

        implicit none

        class(flow),intent(inout) :: this
        type(json_value),pointer,intent(in) :: settings

        logical :: found
        integer :: i

        ! Get flow params
        call json_get(settings, 'freestream_velocity', this%v_inf, found)
        if (.not. found) then
            write(*,*) "Freestream velocity was not specified. Quitting..."
            stop
        end if
        call json_xtnsn_get(settings, 'freestream_mach_number', this%M_inf, 0.0)
        call json_xtnsn_get(settings, 'gamma', this%gamma, 1.4)

        ! Derived quantities
        this%U = norm(this%v_inf)
        this%U_inv = 1./this%U
        this%c0 = -this%v_inf*this%U_inv

        ! Determine condition
        if (this%M_inf == 1.) then
            write(*,*) "A freestream Mach number of 1.0 is not allowed in TriPan. Quitting..."
            stop
        end if
        this%supersonic = this%M_inf > 1.0
        this%incompressible = this%M_inf == 0.

        ! Calculate B and s
        if (this%supersonic) then
            this%B = sqrt(this%M_inf**2-1.)
            this%s = -1.
        else
            this%B = sqrt(1.-this%M_inf**2)
            this%s = 1.
        end if

        ! Calculate freestream speed of sound
        this%c = this%M_inf*this%U

        ! Calculate Mach angle
        this%mu = asin(1.0/this%M_inf)
        this%C_mu = cos(this%mu)

        ! Assemble dual metric matrix
        do i=1,3
            this%psi(i,i) = 1.
        end do
        this%psi = this%psi-this%M_inf**2*outer(this%c0, this%c0)

        ! Calculate C0 matrix
        this%C0_mat = 0.
        this%C0_mat(1,1) = 1.
        this%C0_mat(2,2) = this%s*this%B**2
        this%C0_mat(3,3) = this%s*this%B**2

        ! Check symmetry
        this%sym_about = this%v_inf == 0.

    end subroutine flow_init

    function flow_C0_inner(this, a, b) result(c)
        ! Calculates the inner product a*C0*b = c

        implicit none

        class(flow),intent(in) :: this
        real,dimension(3),intent(in) :: a, b
        real :: c

        c = inner(a, matmul(this%C0_mat, b))

    end function flow_C0_inner

    function flow_point_in_dod(this, Q, P) result(in_dod)
        ! Calculates whether the point Q lies in the dod of point P

        implicit none

        class(flow),intent(in) :: this
        real,dimension(3),intent(in) :: Q, P
        logical :: in_dod

        real,dimension(3) :: d

        ! Calculate displacement
        d = P-Q

        ! Check upstream
        if (inner(d, this%c0) >=0.) then

            ! Check in dod
            if (this%C0_inner(d, d) >= 0.) then

                in_dod = .true.
                return

            end if

        end if

        in_dod = .false.

    end function flow_point_in_dod

end module flow_mod


Function ghvq(y1, y2, amt2)
  Implicit Double Precision (A-H, O-Z)
  Real hipr1(100), hint1(100)
  Common /hparnt/hipr1, ihpr2(50), hint1, ihnt2(50)
  Dimension f(2, 7)
  Save
  xt = 2.0D0*dsqrt(amt2)/dble(hint1(1))
  x1 = 0.5D0*xt*(dexp(y1)+dexp(y2))
  x2 = 0.5D0*xt*(dexp(-y1)+dexp(-y2))
  ss = x1*x2*dble(hint1(1))**2
  af = 4.0D0
  If (ihpr2(18)/=0) af = 5.0D0
  dlam = dble(hipr1(15))
  aph = 12.0D0*3.1415926D0/(33.D0-2.D0*af)/dlog(amt2/dlam**2)
  Call parton(f, x1, x2, amt2)
  gqq = 4.D0*(dcosh(y1-y2)+dble(hipr1(7))**2/amt2)/(1.D0+dcosh(y1-y2))/9.D0*(f(1,1)*f(2,2)+f(1,2)*f(2,1)+f(1,3)*f(2,4)+f(1,4)*f(2,3)+f(1,5)*f(2,6)+f(1,6)*f(2,5))
  ggg = (8.D0*dcosh(y1-y2)-1.D0)*(dcosh(y1-y2)+2.D0*dble(hipr1(7))**2/amt2-2.D0*dble(hipr1(7))**4/amt2**2)/(1.D0+dcosh(y1-y2))/24.D0*f(1, 7)*f(2, 7)
  ghvq = (gqq+ggg)*dble(hipr1(23))*3.14159D0*aph**2/ss**2
  Return
End Function ghvq


	SUBROUTINE VC_PFET  ( etav, ps, zs, ptop, nxy, p, iret )
C************************************************************************
C* VC_PFET								*
C*									*
C* This subroutine computes pressure values on an ETA surface		*
C*									*
C* VC_PFET ( ETAV, PS, ZS, PTOP, NXY, P, IRET )				*
C*									*
C* Input parameters:							*
C*	ETAV  		REAL		ETA value			*
C*	PS (NXY)	REAL		Surface pressure		*
C*	ZS (NXY)	REAL		Surface height			*
C*	PTOP		REAL		Top pressure			*
C*	NXY		INTEGER		Number of grid points		*
C*									*
C* Output parameters:							*
C*	P (NXY)		REAL		Output pressure values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC		06/92						*
C* K. Brill/NMC		08/92	Added all missing check			*
C* T. Lee/GSC		12/99	Used TMCK				*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		p (*), ps (*), zs (*)
C*
	INCLUDE		'ERMISS.FNC'
	DATA		po, tlr / 1013.25, .0065 /
	DATA		expo / 5.25612 /
C*
C-----------------------------------------------------------------------
	iret = 0
	to = TMCK + 15.
C
C*	Compute the pressure values.
C
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( zs (i) ) .or. ERMISS ( ps (i) ) ) THEN
		p (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		aa    = 1. - tlr * zs (i) / to
		prefz = po * aa ** expo
		eee   = ( prefz - ptop ) / ( po - ptop )
		IF ( eee .eq. 0. ) THEN
		    iret = +1
		    RETURN
		END IF
		sgma  = etav / eee
		p (i) = sgma * ( ps (i) - ptop ) + ptop
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RATDEN (P, Q, MTPO, NP, KAPPA, Z)
!                                                                      *
!   This function calculates the ratio of occupation of the orbital in *
!   the P and Q arrays and the hydrogenic orbital defined by NP, KAPPA *
!   and Z in the radial range 0 < r < 0.0219 a.u.                      *
!                                                                      *
!   I.e. in other words, it integrates the densities of the two        *
!   orbitals in that range and the returns their ratio.                *
!                                                                      *
!   Call(s) to: [LIB92]: DCBSRW, QUAD.                                 *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:04:58   1/ 3/07
!...Switches:
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE parameter_def,   ONLY: NNNP
      USE grid_C
      USE tatb_C, ONLY: mtp, ta
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dcbsrw_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: MTPO
      INTEGER  :: NP
      INTEGER  :: KAPPA
      REAL(DOUBLE)  :: Z
      REAL(DOUBLE), INTENT(IN) :: P(NNNP)
      REAL(DOUBLE), INTENT(IN) :: Q(NNNP)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: MTPH, I, K
      REAL(DOUBLE) :: EH, PZH, RESULT, RESULT1
      REAL(DOUBLE), DIMENSION(NNNP) :: PH, QH
!-----------------------------------------------
!
!
!
!   Set up the hydrogenic orbital
!
      CALL DCBSRW (NP, KAPPA, Z, EH, PZH, PH, QH, MTPH)
!
!   Compute the overlap
!
      MTP = MIN(MTPH,MTPO)
      DO I = 2, MTP
         IF (RP(I) > 0.0219) CYCLE
         K = I
      END DO
      MTP = K
      TA(1) = 0.0D00
      TA(2:MTP) = (P(2:MTP)*P(2:MTP)+Q(2:MTP)*Q(2:MTP))*RP(2:MTP)
!         TA(I) = (P(I)*PH(I)+Q(I)*QH(I))*RP(I)
      CALL QUAD (RESULT)
      TA(2:MTP) = (PH(2:MTP)*PH(2:MTP)+QH(2:MTP)*QH(2:MTP))*RP(2:MTP)
      CALL QUAD (RESULT1)
!
      RATDEN = RESULT/RESULT1
!
      RETURN
      END FUNCTION RATDEN