      SUBROUTINE iau_GC2GDE ( A, F, XYZ, ELONG, PHI, HEIGHT, J )
*+
*  - - - - - - - - - - -
*   i a u _ G C 2 G D E
*  - - - - - - - - - - -
*
*  Transform geocentric coordinates to geodetic for a reference
*  ellipsoid of specified form.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     A         d      equatorial radius (Notes 2,4)
*     F         d      flattening (Note 3)
*     XYZ       d(3)   geocentric vector (Note 4)
*
*  Returned:
*     ELONG     d      longitude (radians, east +ve)
*     PHI       d      latitude (geodetic, radians)
*     HEIGHT    d      height above ellipsoid (geodetic, Note 4)
*     J         i      status:  0 = OK
*                              -1 = illegal F
*                              -2 = illegal A
*
*  Notes:
*
*  1) This routine is closely based on the GCONV2H subroutine by
*     Toshio Fukushima (see reference).
*
*  2) The equatorial radius, A, can be in any units, but meters is
*     the conventional choice.
*
*  3) The flattening, F, is (for the Earth) a value around 0.00335,
*     i.e. around 1/298.
*
*  4) The equatorial radius, A, and the geocentric vector, XYZ,
*     must be given in the same units, and determine the units of
*     the returned height, HEIGHT.
*
*  5) If an error occurs (J<0), ELONG, PHI and HEIGHT are unchanged.
*
*  6) The inverse transformation is performed in the routine iau_GD2GCE.
*
*  7) The transformation for a standard ellipsoid (such as WGS84) can
*     more conveniently be performed by calling iau_GC2GD, which uses a
*     numerical code (1 for WGS84) to identify the required A and F
*     values.
*
*  Reference:
*
*     Fukushima, T., "Transformation from Cartesian to geodetic
*     coordinates accelerated by Halley's method", J.Geodesy (2006)
*     79: 689-693
*
*  This revision:  2014 November 7
*
*  SOFA release 2017-04-20
*
*  Copyright (C) 2017 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION A, F, XYZ(3), ELONG, PHI, HEIGHT
      INTEGER J

*  Pi
      DOUBLE PRECISION DPI
      PARAMETER ( DPI = 3.141592653589793238462643D0 )

      DOUBLE PRECISION AEPS2, E2, E4T, EC2, EC, B, X, Y, Z, P2, ABSZ, P,
     :                 S0, PN, ZC, C0, C02, C03, S02, S03, A02, A0, A03,
     :                 D0, F0, B0, S1, CC, S12, CC2

*  -------------
*  Preliminaries
*  -------------

*  Validate ellipsoid parameters.
      IF ( F.LT.0D0 .OR. F.GE.1D0 ) THEN
         J = -1
         GO TO 9999
      ELSE IF ( A .LE. 0D0 ) THEN
         J = -2
         GO TO 9999
      END IF

*  Functions of ellipsoid parameters (with further validation of F).
      AEPS2 = A*A*1D-32
      E2 = (2D0-F)*F
      E4T = E2*E2*1.5D0
      EC2 = 1D0-E2
      IF ( EC2 .LE. 0D0 ) THEN
         J = -1
         GO TO 9999
      END IF
      EC = SQRT(EC2)
      B = A*EC

*  Cartesian components.
      X = XYZ(1)
      Y = XYZ(2)
      Z = XYZ(3)

*  Distance from polar axis squared.
      P2 = X*X + Y*Y

*  Longitude.
      IF ( P2.GT.0D0 ) THEN
         ELONG = ATAN2(Y,X)
      ELSE
         ELONG = 0D0
      END IF

*  Unsigned z-coordinate.
      ABSZ = ABS(Z)

*  Proceed unless polar case.
      IF ( P2.GT.AEPS2 ) THEN

*     Distance from polar axis.
         P = SQRT(P2)

*     Normalization.
         S0 = ABSZ/A
         PN = P/A
         ZC = EC*S0

*     Prepare Newton correction factors.
         C0 = EC*PN
         C02 = C0*C0
         C03 = C02*C0
         S02 = S0*S0
         S03 = S02*S0
         A02 = C02+S02
         A0 = SQRT(A02)
         A03 = A02*A0
         D0 = ZC*A03 + E2*S03
         F0 = PN*A03 - E2*C03

*     Prepare Halley correction factor.
         B0 = E4T*S02*C02*PN*(A0-EC)
         S1 = D0*F0 - B0*S0
         CC = EC*(F0*F0-B0*C0)

*     Evaluate latitude and height.
         PHI = ATAN(S1/CC)
         S12 = S1*S1
         CC2 = CC*CC
         HEIGHT = (P*CC+ABSZ*S1-A*SQRT(EC2*S12+CC2))/SQRT(S12+CC2)
      ELSE

*     Exception: pole.
         PHI = DPI/2D0
         HEIGHT = ABSZ-B
      END IF

*  Restore sign of latitude.
      IF ( Z.LT.0D0 ) PHI = -PHI

*  OK status.
      J = 0

*  Finished.
 9999 CONTINUE

*+----------------------------------------------------------------------
*
*  Copyright (C) 2017
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


      subroutine intphi(lmax,cosrth,r,
     >                  xp,nbnd,
     >                  sumfi)
c     ================================================================
c
      implicit   real*8 (a-h,o-z)
c
      integer    sigma
c
      real*8     cosrth
      real*8     ford(50)
      real*8     xp(3,nbnd)
      real*8     dp2,rhop
      real*8     zero
      real*8     one
      real*8     two
      real*8     half
      real*8     macherr
c
      complex*16 sumfi(0:lmax)
      complex*16 sqrtm1
      complex*16 czero
      complex*16 dummy1,dummy2,exp1,exp2
c
      parameter  (zero=0.0d0)
      parameter  (one=1.0d0)
      parameter  (two=2.0d0)
      parameter  (half=0.5d0)
      parameter  (sqrtm1=(0.0d0,1.0d0))
      parameter  (czero=(0.0d0,0.0d0))
      parameter (pi=3.141592653589793d0)
      parameter (halfpi=half*pi)
      parameter (twopi=two*pi)
      parameter (macherr=1.d-12)
c
      sinrth=sqrt(one-cosrth*cosrth)
      z=r*cosrth
      rho=r*sinrth
c
c     ================================================================
c     find those circle portions within the w-s boundary, and only
c     integrate over phi through them. the value of phi for both
c     ending points of any portion on the boundary are stored in
c     ford.
c     ================================================================
c
      mp=1
      ford(mp)=zero
      do ip=1,nbnd
c
c        =============================================================
c        rp = the distance of the plane from the origin.
c        if r < rp the curve does not touch the plane.
c        if r = rp the curve touches the plane.
c        if r > rp the curve intersects with the plane.
c        mp = the number of intersection points.
c        =============================================================
c
	 rhop=xp(1,ip)*xp(1,ip)+xp(2,ip)*xp(2,ip)
	 dp2=rhop+xp(3,ip)*xp(3,ip)
         if(r*r.gt.dp2.and.rhop.gt.macherr*macherr) then
	    rhop=sqrt(rhop)
	    a=(dp2-xp(3,ip)*z)/(rho*rhop)
            if(abs(a) .le. one+macherr) then
	    if(abs(a).gt.one) a=a/abs(a)
              if(abs(xp(2,ip)) .le. macherr) then
               fi1=halfpi*(one-sign(one,xp(1,ip)))
              else if(xp(2,ip) .ge. zero) then
               fi1=acos(xp(1,ip)/rhop)
              else
               fi1=twopi-acos(xp(1,ip)/rhop)
              endif
	       fi2=acos(a)
               mp=mp+1
               f=fi1-fi2
               if (f.ge.zero) then
                  ford(mp)=f
               else
                  ford(mp)=twopi+f
               end if
               mp=mp+1
               f=fi1+fi2
               if (f.lt.twopi) then
                  ford(mp)=f
               else
                  ford(mp)=f-twopi
               endif
            endif
         endif
      enddo
      mp=mp+1
      ford(mp)=twopi
c
c     ================================================================
c     sort ford so that :   ford(1) < ford(2) < ... < ford(mp).
c     ================================================================
c
c     ----------------------------------------------------------------
      call sort(mp,ford)
c     ----------------------------------------------------------------
c        write(6,'(/,''  the number of phi = '',i4)')mp
c        write(6,'(  ''  ford:: '',i4,2x,1p1e16.9)')
c    >                             (ip,ford(ip),ip=1,mp)
c
c     ================================================================
c     start the phi integration.
c     ================================================================
c
      do m=0,lmax
         sumfi(m)=czero
      enddo
      exp1=exp(-sqrtm1*ford(1))
      exp2=one
      do ip=1,mp-1
c           phi1=ford(ip)
c           phi2=ford(ip+1)
         phi=ford(ip+1)-ford(ip)
         exp1=exp1*conjg(exp2)
	 exp2=exp(sqrtm1*half*phi)
c exp1=exp(-sqrtm1*half*(phi1+phi2))
	 exp1=exp1*conjg(exp2)
c
c     ================================================================
c     sigma:    = 1       if curve between ford(i) and
c                         ford(i+1) is within the cell.
c               = 0       otherwise.
c
c     i = 1,2,...,mp-1
c     ================================================================
c
         fh=half*(ford(ip)+ford(ip+1))
         x=rho*cos(fh)
         y=rho*sin(fh)
c
c        =============================================================
c        check if the point (x,y,z) is inside or outside the
c        polyhedron.
c        =============================================================
c
	if(sigma(x,y,z,xp,nbnd,0).eq.1) then
c
         sumfi(0)=sumfi(0)+phi
	 dummy1=one
	 dummy2=one
         do m=1,lmax
	    dummy1=dummy1*exp1
	    dummy2=dummy2*exp2
            sumfi(m) = sumfi(m) + dummy1*dimag(dummy2)
         enddo
	endif  ! sigma=1
      enddo
      do m=1,lmax
	 sumfi(m)=two*sumfi(m)/m
      enddo
c
      return
      end


MODULE HYPERELASTIC

  IMPLICIT NONE
  INTEGER, PARAMETER :: DP=SELECTED_REAL_KIND(14)
  REAL(KIND=DP), PARAMETER :: HALF=.5_DP, MONE=-1._DP
  REAL(KIND=DP), PARAMETER :: ZERO=0._DP, ONE=1._DP, TWO=2._DP, THREE=3._DP
  REAL(KIND=DP), PARAMETER :: FOUR=4._DP
  REAL(KIND=DP), PARAMETER :: THIRD=ONE/THREE, P2THIRD=TWO/THREE, P3HALF=THREE/TWO
  REAL(KIND=DP), PARAMETER :: FOURTH=ONE/FOUR, SIX=6._DP
  REAL(KIND=DP), PARAMETER :: IIMI4(6,6) = RESHAPE(&
                         [ZERO,  ONE,  ONE, ZERO, ZERO, ZERO, &
                           ONE, ZERO,  ONE, ZERO, ZERO, ZERO, &
                           ONE,  ONE, ZERO, ZERO, ZERO, ZERO, &
                          ZERO, ZERO, ZERO, MONE, ZERO, ZERO, &
                          ZERO, ZERO, ZERO, ZERO, MONE, ZERO, &
                          ZERO, ZERO, ZERO, ZERO, ZERO, MONE], SHAPE(IIMI4))

CONTAINS

  SUBROUTINE HYPEREL(NPROPS, PROPS, TEMP, F, NOEL, CMNAME, INCMPFLAG, &
       NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, PK2, CVOL, CISO)
    ! ----------------------------------------------------------------------- !
    ! HYPERELASTIC MATERIAL MODEL
    ! CALLS A UYHPER MODEL AND FORMULATES THE STRESS AND STIFFNESS ARRAYS
    ! ----------------------------------------------------------------------- !
    USE TENSALG, ONLY : DET,INVARS,INV,DYAD,SYMSHUFF,SYMSQ,I6,II1,II5
    ! --- PASSED ARGUMENTS
    CHARACTER*8, INTENT(IN) :: CMNAME
    INTEGER, INTENT(IN) :: NPROPS, NOEL, NSTATV, INCMPFLAG, NFLDV
    REAL(KIND=DP), INTENT(IN) :: PROPS(NPROPS), TEMP, F(3,3)
    REAL(KIND=DP), INTENT(INOUT) :: STATEV(NSTATV), FIELDV(NFLDV), DFIELDV(NFLDV)
    REAL(KIND=DP), INTENT(OUT) :: PK2(6), CVOL(6,6), CISO(6,6)
    ! --- LOCAL VARIABLES
    INTEGER :: I
    REAL(KIND=DP) :: JAC, C(6)
    REAL(KIND=DP) :: U(2), DU(3), D2U(6), D3U(6)
    REAL(KIND=DP) :: I1, I2, I3, I1B, I2B
    REAL(KIND=DP) :: SCALE, CI(6), A(3), DA(3,6), B(3,6), DB(3,6,6)
    REAL(KIND=DP) :: TERM1(6,6), TERM2(6,6)
    REAL(KIND=DP), DIMENSION(6,6) :: CII, ICI, CICI, LCICI, CCI, CIC
    ! ----------------------------------------------------------- HYPEREL --- !

    ! DEFORMATION TENSOR
    ! C = FT.F
    C = SYMSQ(F)

    ! JACOBIAN
    JAC = DET(F)

    ! INVARIANTS OF C
    CALL INVARS(C, I1, I2, I3)

    ! INVARIANTS OF CBAR
    SCALE = JAC ** (-ONE / THREE)
    I1B = I1 * (SCALE ** 2)
    I2B = I2 * (SCALE ** 4)

    CALL UHYPER(I1B, I2B, JAC, U, DU, D2U, D3U, TEMP, NOEL, CMNAME, &
         INCMPFLAG, NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, &
         NPROPS, PROPS)

    ! UPDATE THE STRESS AND MATERIAL STIFFNESS
    ! THE NOTATION BELOWS FOLLOWS THE APPENDIX OF ***TITLE*** WHERE
    ! THE SECOND PIOLA-KIRCHOFF STRESS IS GIVEN BY
    !
    !                           DU   DU  DIB
    !                   PK2 = 2 -- = --- --- = A.B
    !                           DC   DIB DC
    !
    ! WHERE A IS AN ARRAY CONTAINING THE DERIVATIVES OF U WRT ISOCHORIC
    ! INVARIANTS AND B IS AN ARRAY OF TENSORS CONTAINING THE DERIVATIVES OF
    ! THE ISOCHORIC INVARIANTS WRT C

    ! HELPER QUANTITIES
    CI = INV(C)

    A = DU
    B(1,1:6) = SCALE ** 2 * (I6 - THIRD * I1 * CI)
    B(2,1:6) = SCALE ** 4 * (I1 * I6 - C - P2THIRD * I2 * CI)
    B(3,1:6) = HALF * JAC * CI

    ! SECOND PIOLA-KIRCHHOFF STRESS: DERIVATIVE OF ENERGY WRT C
    FORALL(I=1:6) PK2(I) = TWO * SUM(A(1:3) * B(1:3, I))

    ! USING THE NOTATION FROM ABOVE, THE MATERIAL STIFFNESS L IS
    !
    !                      L  = 4(DA.B + A.DB)
    !
    !            DA   DA  DIB   D2U
    ! WHERE DA = -- = --- --- = ----.B
    !            DC   DIB DC    DIB2
    !
    !          DB
    ! AND DB = --
    !          DC
    !
    ! NOTE THAT DA AND B CONTAIN SECOND ORDER TENSORS SO THAT THE ARRAY DA.B
    ! IS AN ARRAY OF DYADIC PRODUCTS OF SECOND ORDER TENSORS (FOURTH ORDER
    ! TENSORS). DB IS AN ARRAY OF FOURTH ORDER TENSORS.

    ! HELPER QUANTITIES
    CICI = DYAD(CI, CI)
    CIC = DYAD(CI, C)
    CCI = DYAD(C, CI)
    LCICI = SYMSHUFF(CI)
    ICI = DYAD(I6, CI)
    CII = DYAD(CI, I6)

    ! DA/DC
    DA=ZERO
    DA(1,1:6) = D2U(1) * B(1,1:6) + D2U(4) * B(2,1:6) + D2U(5) * B(3,1:6)
    DA(2,1:6) = D2U(4) * B(1,1:6) + D2U(2) * B(2,1:6) + D2U(6) * B(3,1:6)
    DA(3,1:6) = D2U(5) * B(1,1:6) + D2U(6) * B(2,1:6) + D2U(3) * B(3,1:6)

    ! DB/DC
    DB = ZERO

    TERM1 = CII + ICI
    TERM2 = I1 * (LCICI + THIRD * CICI)
    DB(1,1:6,1:6) = THIRD * SCALE ** 2 * (-TERM1 + TERM2)

    TERM1 = P3HALF * (II1 - II5) + (CIC + CCI)
    TERM2 = -I1 * (CII + ICI) + I2 * (LCICI + P2THIRD * CICI)
    DB(2,1:6,1:6) = P2THIRD * SCALE ** 4 * (TERM1 + TERM2)

    DB(3,1:6,1:6) = FOURTH * JAC * (CICI - TWO * LCICI)

    ! ISOCHORIC PART
    CISO = ZERO
    DO I=1,2
       TERM1 = FOUR * (DYAD(DA(I,1:6), B(I,1:6)) + DU(I) * DB(I,1:6,1:6))
       CISO = CISO + TERM1
    END DO
    CISO = HALF * (CISO + TRANSPOSE(CISO))

    ! VOLUMETRIC PART
    CVOL = FOUR * (DYAD(DA(3,1:6), B(3,1:6)) + DU(3) * DB(3,1:6,1:6))
    CVOL = HALF * (CVOL + TRANSPOSE(CVOL))

  END SUBROUTINE HYPEREL

  ! ************************************************************************* !

  SUBROUTINE PUSHALL(F, PK2, CVOL, CISO, CFAC, STRESS, DDSDDE)
    ! ----------------------------------------------------------------------- !
    USE TENSALG, ONLY : PUSH, SYMSHUFF, I6
    ! --- PASSED ARGUMENTS
    REAL(KIND=DP), INTENT(IN) :: F(3,3), PK2(6), CVOL(6,6), CISO(6,6), CFAC(2)
    REAL(KIND=DP), INTENT(OUT) :: STRESS(6), DDSDDE(6,6)
    REAL(KIND=DP) :: TERM1(6,6), TERM2(6,6)
    ! ----------------------------------------------------------- PUSHALL --- !
    STRESS = PUSH(F, PK2)
    TERM1 = (ONE - CFAC(1)) * CISO + (ONE - CFAC(2)) * CVOL
    DDSDDE = PUSH(F, TERM1)

    ! THE CONSTITUTIVE EQUATIONS FOR THE HYPERELASTIC MATERIAL GIVES THE
    ! STRESS IN THE SPATIAL CONFIGURATION (CAUCHY STRESS). HOWEVER, THE
    ! CONSTITITUVE RESPONSE IS IN TERMS OF THE LIE DERIVATIVE, OR TRUESDELL
    ! RATE, OF THE KIRCHOFF STRESS. THE JAUMMANN RATE IS AN ALTERNATIVE LIE
    ! DERIVATIVE, GIVEN BY
    !                              _   .
    !                              S = S + S.W - W.S
    !       _
    ! WHERE S IS THE JAUMMANN RATE OF THE CAUCHY STRESS S. USING THE JAUMMANN
    ! RATE, THE CONSTITUTIVE RESPONSE IN THE COROTATED FRAME IS GIVEN BY
    !                                 _   _
    !                                 S = C:D
    !       _
    ! WHERE C IS THE JAUMMANN TANGENT STIFFNESS TENSOR AND IS DEFINED
    ! IMPLICITY FROM
    !                           _
    !                           S = C:D + D.S + S.D
    ! FROM WHICH
    !           _
    !           C = C + .5 (Iik Sjl + Iil Sjk + Sik Ijl + Sil Ijk)
    TERM1 = SYMSHUFF(I6, STRESS)
    TERM2 = SYMSHUFF(STRESS, I6)
    DDSDDE = DDSDDE + (TERM1 + TERM2)

  END SUBROUTINE PUSHALL

  ! ************************************************************************* !

  SUBROUTINE NUMERICAL_JACOBIAN(NPROPS, PROPS, TEMP, NOEL, CMNAME, INCMPFLAG, &
       NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, F, DDSDDE)
    ! THIS PROCEDURE NUMERICALLY COMPUTES AND RETURNS THE JACOBIAN MATRIX
    !
    !                      J = (JIJ) = (DSIGI/DEPSJ).
    !
    ! THE COMPONENTS OF JSUB ARE COMPUTED NUMERICALLY USING A CENTERED
    ! DIFFERENCING SCHEME WHICH REQUIRES TWO CALLS TO THE MATERIAL MODEL
    ! SUBROUTINE FOR EACH ELEMENT OF PK2. THE CENTERING IS ABOUT THE POINT
    !                       EPS = EPSOLD + D * DT,
    ! WHERE D IS THE RATE-OF-STRAIN ARRAY.
    USE TENSALG, ONLY: PUSH
    REAL(KIND=DP), PARAMETER :: TOL=1.E-6_DP
    CHARACTER*8, INTENT(IN) :: CMNAME
    INTEGER, INTENT(IN) :: NPROPS, NOEL, NSTATV, INCMPFLAG, NFLDV
    REAL(KIND=DP), INTENT(IN) :: PROPS(NPROPS), TEMP, STATEV(NSTATV)
    REAL(KIND=DP), INTENT(INOUT) :: FIELDV(NFLDV), DFIELDV(NFLDV)
    REAL(KIND=DP), INTENT(IN) :: F(3,3)
    REAL(KIND=DP), INTENT(OUT) :: DDSDDE(6,6)
    INTEGER :: N
    REAL(KIND=DP) :: EPS, DF(3,3), CISO(6,6), CVOL(6,6)
    REAL(KIND=DP) :: SVP(NSTATV), FP(3,3), TP(6), SP(6)
    REAL(KIND=DP) :: SVM(NSTATV), FM(3,3), TM(6), SM(6)
    ! ---------------------------------------------------------- JACOBIAN --- !
    DDSDDE = ZERO
    EPS = SQRT(EPSILON(ONE))
    DO N = 1, 6
       DF = DGEDDG(EPS/TWO, N, F)
       FP = F + DF
       SVP = STATEV
       CALL HYPEREL(NPROPS, PROPS, TEMP, FP, NOEL, CMNAME, INCMPFLAG, NSTATV,&
            SVP, NFLDV, FIELDV, DFIELDV, TP, CVOL, CISO)
       SP = PUSH(FP, TP)
       FM = F - DF
       SVM = STATEV
       CALL HYPEREL(NPROPS, PROPS, TEMP, FM, NOEL, CMNAME, INCMPFLAG, NSTATV,&
            SVM, NFLDV, FIELDV, DFIELDV, TM, CVOL, CISO)
       SM = PUSH(FM, TM)
       DDSDDE(:, N) = (SP - SM) / EPS
    END DO
    DDSDDE = HALF * (DDSDDE + TRANSPOSE(DDSDDE))
  END SUBROUTINE NUMERICAL_JACOBIAN

  ! ************************************************************************* !

  FUNCTION DGEDDG(EPS, N, F)
    ! -----------------------------------------------------------------------
    !  !
    ! PERTURB THE DEFORMATION GRADIENT
    ! -----------------------------------------------------------------------
    !  !
    USE TENSALG, ONLY: DYAD
    INTEGER, INTENT(IN) :: N
    REAL(KIND=DP), INTENT(IN) :: EPS, F(3,3)
    REAL(KIND=DP) :: DGEDDG(3,3)
    REAL(KIND=DP), PARAMETER :: O=1._DP,Z=0._DP
    REAL(KIND=DP), PARAMETER :: E(3,3)=RESHAPE((/O,Z,Z,Z,O,Z,Z,Z,O/),(/3,3/))
    INTEGER, PARAMETER :: IJ(2,6)=RESHAPE((/1,1,2,2,3,3,1,2,1,3,2,3/),(/2,6/))
    REAL(KIND=DP) :: EI(3), EJ(3), EIJ(3,3), EJI(3,3)
    ! -----------------------------------------------------------------------
    !  !
    EI = E(IJ(1,N),:3)
    EJ = E(IJ(2,N),:3)
    EIJ = DYAD(EI, EJ)
    EJI = DYAD(EJ, EI)
    DGEDDG = EPS / TWO * (MATMUL(EIJ, F) + MATMUL(EJI, F))
  END FUNCTION DGEDDG

  ! ************************************************************************* !

  SUBROUTINE NEOHOOKE(NPROPS, PROPS, F, SIG, C)
    ! --------------------------------------------------------------------- !
    ! COMPRESSIBLE NEO-HOOKEAN HYPERELASTIC MATERIAL
    !
    ! NOTES
    ! -----
    ! SYMMETRIC TENSOR ORDERING : XX, YY, ZZ, XY, YZ, ZX
    ! --------------------------------------------------------------------- !
    USE TENSALG, ONLY: I6
    INTEGER, INTENT(IN) :: NPROPS
    REAL(DP), INTENT(IN) :: PROPS(NPROPS), F(3,3)
    REAL(DP), INTENT(INOUT) :: SIG(6), C(6,6)
    INTEGER :: I, J
    REAL(DP) :: EE(6), EEP(3), BBP(3), BBN(3,3)
    REAL(DP) :: C10, D1, EG, EK, EG23, PR
    REAL(DP) :: JAC, SCALE, FB(3,3), BB(6), TRBBAR

    ! ELASTIC PROPERTIES
    C10 = PROPS(1)
    D1 = PROPS(2)

    ! JACOBIAN AND DISTORTION TENSOR
    JAC = F(1,1) * F(2,2) * F(3,3) - F(1,2) * F(2,1) * F(3,3) + F(1,2) * F(2&
         &,3) * F(3,1) + F(1,3) * F(3,2) * F(2,1) - F(1,3) * F(3,1) * F(2,2) &
         &- F(2,3) * F(3,2) * F(1,1)
    SCALE = JAC **(-ONE / THREE)
    FB = SCALE * F

    ! DEVIATORIC LEFT CAUCHY-GREEN DEFORMATION TENSOR
    BB(1) = FB(1,1) * FB(1,1) + FB(1,2) * FB(1,2) + FB(1,3) * FB(1,3)
    BB(2) = FB(2,1) * FB(2,1) + FB(2,2) * FB(2,2) + FB(2,3) * FB(2,3)
    BB(3) = FB(3,1) * FB(3,1) + FB(3,2) * FB(3,2) + FB(3,3) * FB(3,3)
    BB(4) = FB(2,1) * FB(1,1) + FB(2,2) * FB(1,2) + FB(2,3) * FB(1,3)
    BB(5) = FB(3,1) * FB(2,1) + FB(3,2) * FB(2,2) + FB(3,3) * FB(2,3)
    BB(6) = FB(3,1) * FB(1,1) + FB(3,2) * FB(1,2) + FB(3,3) * FB(1,3)
    TRBBAR = SUM(BB(1:3)) / THREE
    EG = TWO * C10 / JAC
    EK = TWO / D1 * (TWO * JAC - ONE)
    PR = TWO / D1 * (JAC - ONE)

    ! CAUCHY STRESS
    SIG = EG * (BB - TRBBAR * I6) + PR * I6

    ! SPATIAL STIFFNESS
    EG23 = EG * TWO / THREE
    C(1,1) =  EG23 * (BB(1) + TRBBAR) + EK
    C(1,2) = -EG23 * (BB(1) + BB(2)-TRBBAR) + EK
    C(1,3) = -EG23 * (BB(1) + BB(3)-TRBBAR) + EK
    C(1,4) =  EG23 * BB(4) / TWO
    C(1,5) = -EG23 * BB(5)
    C(1,6) =  EG23 * BB(6) / TWO
    C(2,2) =  EG23 * (BB(2) + TRBBAR) + EK
    C(2,3) = -EG23 * (BB(2) + BB(3)-TRBBAR) + EK
    C(2,4) =  EG23 * BB(4) / TWO
    C(2,5) =  EG23 * BB(5) / TWO
    C(2,6) = -EG23 * BB(6)
    C(3,3) =  EG23 * (BB(3) + TRBBAR) + EK
    C(3,4) = -EG23 * BB(4)
    C(3,5) =  EG23 * BB(5) / TWO
    C(3,6) =  EG23 * BB(6) / TWO
    C(4,4) =  EG * (BB(1) + BB(2)) / TWO
    C(4,5) =  EG * BB(6) / TWO
    C(4,6) =  EG * BB(5) / TWO
    C(5,5) =  EG * (BB(1) + BB(3)) / TWO
    C(5,6) =  EG * BB(4) / TWO
    C(6,6) =  EG * (BB(2) + BB(3)) / TWO
    FORALL(I=1:6,J=1:6,J<I) C(I,J) = C(J,I)
    RETURN
  END SUBROUTINE NEOHOOKE
END MODULE HYPERELASTIC

! *************************************************************************** !

SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD, RPL,DDSDDT,DRPLDE,DRPLDT,&
     & STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME, NDI,NSHR,NTENS&
     &,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT, CELENT,F0,F1,NOEL,NPT,LAYER&
     &,KSPT,KSTEP,KINC)
  ! -------------------------------------------------------------------------
  !  !
  !     UMAT INTERFACE FOR FINITE STRAIN PROPELLANT MODEL
  ! -------------------------------------------------------------------------
  !  !
  !     CANNOT BE USED FOR PLANE STRESS
  !     PROPS(1)  - C10
  !     PROPS(2)  - K1
  ! -------------------------------------------------------------------------
  !  !
  USE HYPERELASTIC, ONLY: DP, ZERO, ONE, TWO, THREE, HYPEREL, &
       NUMERICAL_JACOBIAN, NEOHOOKE, PUSHALL
  IMPLICIT NONE

  ! --- PASSED ARGUMENTS
  ! -------------------------------------------------------------------------
  !  !
  CHARACTER*8, INTENT(IN) :: CMNAME
  INTEGER, INTENT(IN) :: NDI, NSHR, NTENS, NSTATV, NPROPS
  INTEGER, INTENT(IN) :: NOEL, NPT, LAYER, KSPT, KSTEP, KINC
  REAL(KIND=DP), INTENT(IN) :: SSE, SPD, SCD, RPL, DRPLDT, TIME(2), DTIME
  REAL(KIND=DP), INTENT(IN) :: TEMP, DTEMP, PNEWDT, CELENT
  REAL(KIND=DP), INTENT(INOUT) :: STRESS(NTENS), STATEV(NSTATV)
  REAL(KIND=DP), INTENT(INOUT) :: DDSDDE(NTENS, NTENS)
  REAL(KIND=DP), INTENT(INOUT) :: DDSDDT(NTENS), DRPLDE(NTENS)
  REAL(KIND=DP), INTENT(IN) :: STRAN(NTENS), DSTRAN(NTENS)
  REAL(KIND=DP), INTENT(IN) :: PREDEF(1), DPRED(1), PROPS(NPROPS), COORDS(3)
  REAL(KIND=DP), INTENT(IN) :: DROT(3, 3), F0(3, 3), F1(3, 3)
  ! --- LOCAL VARIABLES
  INTEGER, PARAMETER :: NFLDV=1, INCMPFLAG=1
  REAL(KIND=DP) :: FIELDV(NFLDV), DFIELDV(NFLDV), ERR
  REAL(KIND=DP) :: PK2(6), CVOL(6,6), CISO(6,6), CFAC(2)
  REAL(KIND=DP), ALLOCATABLE :: SNEO(:), CNEO(:,:), S(:), C(:,:), CNUM(:,:)
  INTEGER :: INTV(1), DBGFLG, I
  CHARACTER*120 :: MSG
  REAL(KIND=DP) :: REALV(1)
  CHARACTER*8 :: CHARV(1)
  ! ---------------------------------------------------------------- UMAT --- !
  DDSDDE = 0._DP
  CALL HYPEREL(NPROPS, PROPS, TEMP, F1, NOEL, CMNAME, INCMPFLAG, &
       NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, PK2, CVOL, CISO)
  CFAC = ZERO
  CALL PUSHALL(F1, PK2, CVOL, CISO, CFAC, STRESS, DDSDDE)

  DBGFLG = 0
  SELECT CASE (DBGFLG)
  CASE (1)
     ! NUMERICAL JACOBIAN
     CALL NUMERICAL_JACOBIAN(NPROPS, PROPS, TEMP, NOEL, CMNAME, INCMPFLAG, &
          NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, F1, DDSDDE)
  CASE (2)
     ALLOCATE(SNEO(6))
     CALL NEOHOOKE(2, (/PROPS(1),PROPS(2)/), F1, SNEO, DDSDDE)
     DEALLOCATE(SNEO)
  CASE (3)

     ALLOCATE(SNEO(6))
     ALLOCATE(CNEO(6,6))
     ALLOCATE(CNUM(6,6))
     ALLOCATE(S(6))
     ALLOCATE(C(6,6))
     C = DDSDDE
     S = STRESS
     WHERE (ABS(C) < EPSILON(ONE))
        C = ONE
     END WHERE
     WHERE (ABS(S) < EPSILON(ONE))
        S = ONE
     END WHERE

     ! NUMERICAL JACOBIAN
     CALL NUMERICAL_JACOBIAN(NPROPS, PROPS, TEMP, NOEL, CMNAME, INCMPFLAG, &
          NSTATV, STATEV, NFLDV, FIELDV, DFIELDV, F1, CNUM)

     ! NEO HOOKE JACOBIAN
     CALL NEOHOOKE(2, (/PROPS(1),PROPS(2)/), F1, SNEO, CNEO)
     ERR = MAXVAL(((SNEO - STRESS) / S))
     IF (ERR > 1.E-8_DP) THEN
        WRITE(MSG, "(A,ES9.3)") "ERROR IN STRESS: ", ERR
        CALL STDB_ABQERR(-1, MSG, INTV, REALV, CHARV)
     END IF

     ERR = MAXVAL(ABS((CNEO - DDSDDE) / C))
     IF (ERR > 1.E-8_DP) THEN
        WRITE(MSG, "(A,ES9.3)") "ERROR IN STIFFNESS: ", ERR
        CALL STDB_ABQERR(-1, MSG, INTV, REALV, CHARV)
     END IF

     DEALLOCATE(SNEO, CNEO, CNUM, S, C)
  END SELECT

END SUBROUTINE UMAT


      subroutine wshscs(peaksu,ieltmp,nh,qpmax)
c
c     + + + PURPOSE + + +
c
c     SR WSHSCS calculates SCS Triangular Hydrographs when
c     surface flows from hillslopes, channels and impoundments
c     merge onto a channel or into an impoundment. The hydrographs
c     are then superimposed to find a single peak runoff rate.
c
c     Called from: SR WSHPEK
c     Author(s): Ascough II
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxelm.inc'
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxprt.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real peaksu(3), qpmax
      integer ieltmp(3), nh
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     peaksu -
c     qpmax  -
c     ieltmp -
c     nh     -
c
c     + + + COMMON BLOCKS + + +
c
      include 'chydrol.inc'
      include 'cstore.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real delta1, delta2, h(3,1440), hcomp(1440), htot, tend(3),
     1    timeb(3), timep(3), tmax
      integer i, j, k, ntime
c
c     + + + LOCAL DEFINITIONS + + +
c
c     delta1 -
c     delta2 -
c     h(10,1440)  -
c     hcomp(1440) -
c     htot -
c     tend(10)    -
c     timeb(10)   -
c     timep(10)   -
c     tmax        -
c     i -
c     j -
c     k -
c     ntime -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      tmax = 0.0
c
      do 10 i = 1, nh
c
c       calculate the base time (mins) for the SCS Triangular
c       Hydrographs
c
c       WEPP Units   --> Area (m^2), Runoff (m), Peak Runoff (m^3/s)
c       SCS TH units --> Area (km^2), Runoff (mm), Peak Runoff (m^3/s),
c       (33.333 = 12.4844 * 2.67 from SCS TH Equation)
c
        timeb(i) = (33.333*(wsarea(ieltmp(i))/1.0e6)*(
     1      rofave(ieltmp(i))*1.0e3)) / peaksu(i)
c
        if (timeb(i).gt.tmax) tmax = timeb(i)
c
c       calculate the time to peak (mins)
c
        timep(i) = timeb(i) / 2.67
c
        tend(i) = timeb(i)
c
   10 continue
c
c     if tmax is greater than one day then limit the hydrograph
c     calculations
c
      if (tmax.gt.1440.0) tmax = 1440.0
      ntime = int(tmax)
c
c     calculate time-discharge relationship for each hydrograph
c
      do 30 j = 1, ntime
        do 20 i = 1, nh
          h(i,j) = 0.0
   20   continue
        hcomp(j) = 0.0
   30 continue
c
      do 50 i = 1, nh
c
        delta1 = peaksu(i) / timep(i)
        delta2 = peaksu(i) / (timeb(i)-timep(i))
c
        k = 0
c
        do 40 j = 1, ntime
c
          if (float(j).gt.tend(i)) then
            h(i,j) = 0.0
            go to 40
          end if
c
          if (float(j).lt.timep(i)) then
            if (j.eq.1) h(i,j) = delta1
            if (j.gt.1) h(i,j) = h(i,j-1) + delta1
          else
            if (k.eq.0) then
              h(i,j) = peaksu(i)
              k = 1
            else
              h(i,j) = h(i,j-1) - delta2
            end if
          end if
c
          if (h(i,j).lt.0.0) h(i,j) = 0.0
c
   40   continue
   50 continue
c
      qpmax = 0.0
c
      do 70 i = 1, ntime
        htot = 0.0
        do 60 j = 1, nh
          htot = htot + h(j,i)
   60   continue
        hcomp(i) = htot
        if (hcomp(i).gt.qpmax) qpmax = hcomp(i)
   70 continue
c
      return
      end