C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE RENUM (NPNODE, NPELEM, MXNFLG, MXSFLG, NPNBC, NPSBC,
     &   NPWTS, NPREGN, MP, ML, MS, MR, MSC, MAXKXN, NNUID, NNXK,
     &   MXLPS, IUNIT, NNN, KKK, KCRD, NL, NPBF, NLBF, NSBF, IPART,
     &   LSTNBC, LSTSBC, NNFLG, NNPTR, NNLEN, NSFLG, NSPTR, NSLEN,
     &   NVPTR, NVLEN, NSIDEN, NUID, XN, YN, NXK, MAT, KXN, LIST, LA,
     &   LB, MATMAP, LISTN, WTNODE, WTSIDE, WTHOLD, IHERE, ILIST, XLIST,
     &   NUMMAT, NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, COOR, ILINE,
     &   LTYPE, LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS,
     &   LINKR, IMAT, LINKB, JMAT, IPBF, NPPF, IFPB, LISTPB, IWTPBF,
     &   ILBF, NLPF, IFLB, LISTLB, IWTLBF, ISBF, NSPF, IFSB, LISTSB,
     &   IWTSBF, LINKPB, LINKLB, LINKSB, NUMBER, THREE, EIGHT, NINE,
     &   OPTIM, ISBARS)
C***********************************************************************

C  SUBROUTINE RENUM = NUMBERS QMESH OUTPUT, AND RENUMBERS AS NEEDED FOR
C                     OPTIMIZATION

C***********************************************************************

C    THE REFERENCE DOCUMENTS FOR THIS CODE ARE SLA-73-1088, JULY 1974,
C    AND SLA-74-0239, JULY 1974

C***********************************************************************

      DIMENSION NLIST(20), IPART(3, NPREGN)
      DIMENSION COOR(2, MP), ILINE(ML), LTYPE(ML), LCON(3, ML)
      DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3)
      DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS)
      DIMENSION LINKR(2, MR)
      DIMENSION IMAT(MR), JMAT(MS)
      DIMENSION IPBF(MP), NPPF(MP), IFPB(MP), LISTPB(2, MP)
      DIMENSION ILBF(ML), NLPF(ML), IFLB(ML), LISTLB(2, ML)
      DIMENSION ISBF(ML), NSPF(ML), IFSB(ML), LISTSB(2, ML)
      DIMENSION IWTPBF(3, MP), IWTLBF(3, ML), IWTSBF(3, ML)
      DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML)

      DIMENSION LIST(NNUID), LISTN(NNUID), NUID(NNUID), XN(NPNODE)
      DIMENSION YN(NPNODE), NXK(NNXK, NPELEM), MAT(NPELEM)
      DIMENSION KXN(NNXK, MAXKXN), LA(NPNODE), LB(NPNODE)
      DIMENSION IHERE(NNUID), ILIST(MXLPS), XLIST(MXLPS)

      DIMENSION LSTNBC(NPNBC), LSTSBC(NPSBC), NSIDEN(NPSBC)
      DIMENSION NNFLG(MXNFLG), NNLEN(MXNFLG), NNPTR(MXNFLG)
      DIMENSION NSFLG(MXSFLG), NSLEN(MXSFLG), NSPTR(MXSFLG)
      DIMENSION WTHOLD(NPWTS), WTNODE(NPNBC), WTSIDE(NPSBC)
      DIMENSION NVLEN(MXSFLG), NVPTR(MXSFLG), MATMAP(3, NPREGN)

      DIMENSION KLIST(20)

      LOGICAL OPTIM, ERR, NOROOM, ALL, THREE, EIGHT, NINE
      LOGICAL ITSOK, ISBARS

      CHARACTER*80 NUMBER(MSC)

C  HEADER

      CALL MESAGE (' ')
      CALL MESAGE ('NUMBERING OF GENERATED OUTPUT BEGUN')
      IF (OPTIM) CALL MESAGE ('  -- OPTIMIZATION IS ENABLED --')

C  READ THE MESH TAPE

      CALL RDMESH (NPNODE, NPELEM, NPNBC, NPSBC, NPREGN, MS, MR, NNUID,
     &   NNXK, IUNIT, NNN, KKK, IPART, LSTNBC, LSTSBC, NUID, XN, YN,
     &   NXK, MAT, MATMAP, NUMMAT, ISIDE, NLPS, IFLINE, ILLIST, LINKS,
     &   LINKR, IMAT, LINKB, JMAT, NNNBC, NNSBC, ERR)
      IF (ERR) THEN
         CALL MESAGE ('** NUMBERING ABORT **')
         RETURN
      END IF

C  SORT NODE LIST INTO INCREASING NUID-S

      DO 100 I = 1, NNN
         LISTN(I) = NUID(I)
  100 CONTINUE
      IF (OPTIM) THEN
         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)
      ELSE
         DO 110 I = 1, NNN
            LIST(I) = I
  110    CONTINUE
         CALL SORT (NNN, NUID, LIST)
      END IF

C  CONVERT REFERENCES TO NUID-S TO REFERENCES TO
C  SEQUENCE NUMBERS

      DO 130 I = 1, 4
         DO 120 K = 1, KKK
            IF (NXK(I, K) .GT. 0) THEN
               NEW = INDX(NNN, NUID, NXK(I, K))
               IF (NEW .EQ. 0) THEN
                  CALL MESAGE ('ERROR SORTING NUMBERING DATA -- NODE')
                  CALL MESAGE ('*** NO MESH SAVED ***')
                  KKK = 0
                  RETURN
               END IF
               IF (OPTIM) THEN
                  NXK(I, K) = NEW
               ELSE
                  NXK(I, K) = LIST(NEW)
               END IF
            END IF
  120    CONTINUE
  130 CONTINUE

      IF (NNNBC .GT. 0) THEN
         DO 140 I = 1, NNNBC
            IF (LSTNBC(I) .GT. 0) THEN
               NEW = INDX(NNN, NUID, LSTNBC(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESAGE ('ERROR SORTING NUMBERING DATA -- NBC')
                  CALL MESAGE ('*** NO MESH SAVED ***')
                  KKK = 0
                  RETURN
               END IF
               IF (OPTIM) THEN
                  LSTNBC(I) = NEW
               ELSE
                  LSTNBC(I) = LIST(NEW)
               END IF
            END IF
  140    CONTINUE
      END IF

C  BUILD KXN ARRAY

      NUMKXN = NNN
      DO 160 I = 1, NNXK
         DO 150 J = 1, MAXKXN
            KXN(I, J) = 0
  150    CONTINUE
  160 CONTINUE

      DO 180 I = 1, 4
         DO 170 K = 1, KKK
            IF (NXK(I, K) .GT. 0) THEN
               CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K),
     &            ERR)
               IF (ERR) THEN
                  CALL MESAGE ('** NUMBERING ABORT **')
                  KKK = 0
                  RETURN
               END IF
            END IF
  170    CONTINUE
  180 CONTINUE
      IF (OPTIM) THEN

C  GET STARTING LIST FOR CUTHILL-MCKEE PROCESS

         IF (KCRD .GT. 0) THEN
            CALL GNLIST (NPNODE, NNUID, MSC, NPNODE, NPELEM, MAXKXN,
     &         NNXK, KXN, NXK, NUID, XN, YN, LIST, NUML, NUMBER, KCRD,
     &         NNN, ERR, NOROOM)
            IF (NOROOM) THEN
               CALL MESAGE ('TOO MANY NODES IN STARTING LIST')
               CALL MESAGE ('*** NO MESH SAVED ***')
               CALL MESAGE ('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            ELSE IF (ERR) THEN
               CALL MESAGE ('ERROR GENERATING STARTING LIST')
               CALL MESAGE ('*** NO MESH SAVED ***')
               CALL MESAGE ('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            END IF
         ELSE
            CALL MESAGE ('NO CARDS AVAILABLE FOR STARTING LIST')
            CALL MESAGE ('FIRST NODE IN THE OUTPUT USED')
            NUML = 1
            LIST(1) = 1
         END IF

C  INITIALIZE LISTS

         DO 190 I = 1, NNN
            LISTN(I) = I
  190    CONTINUE

C  USE LISTN AS A CHECK ON WHETHER THE NODE HAS BEEN USED (NEGATED)

         DO 200 I = 1, NUML
            LA(I) = LIST(I)
            NODE = LIST(I)
            LISTN(NODE) = -LISTN(NODE)
  200    CONTINUE

         NUMA = NUML

C  CREATE LIST OF NEW NODES CONNECTED TO LIST A

  210    CONTINUE
         NUMB = 0
         DO 230 N = 1, NUMA
            ALL = .TRUE.
            CALL GETNXN (NPNODE, NPELEM, MAXKXN, NNXK, KXN, NXK, LISTN,
     &         LA(N), NLIST, NUMB1, ALL, ERR)
            IF (ERR) THEN
               CALL MESAGE ('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            END IF
            IF (NUMB1 .GT. 0) THEN
               IF ((NUMB + NUMB1) .GT. NPNODE) THEN
                  CALL MESAGE ('LIST B HAS OVERFLOWED')
                  CALL MESAGE ('*** NO MESH SAVED  ***')
                  CALL MESAGE ('** NUMBERING ABORT **')
                  KKK = 0
                  RETURN
               END IF
               DO 220 I = 1, NUMB1
                  NODE = NLIST(I)
                  NUMB = NUMB + 1
                  LB(NUMB) = NODE
                  LISTN(NODE) = -LISTN(NODE)
  220          CONTINUE
            END IF
  230    CONTINUE
         IF (NUMB .GT. 0) THEN

C  INCLUDE LIST B INTO FULL LIST
C  ALSO TRANSFER LIST B TO LIST A

            DO 240 I = 1, NUMB
               NUML = NUML + 1
               LIST(NUML) = LB(I)
               LA(I) = LB(I)
  240       CONTINUE
            NUMA = NUMB

C  CHECK FOR CONVERGENCE

            IF (NUML .LT. NNN) GO TO 210

C  PROCESS HAS CONVERGED
C  CHECK IF ALL NODES WERE COVERED

         ELSE IF (NUML .LT. NNN) THEN

            DO 250 I = 1, NNN
               IF (LISTN(I) .GT. 0) THEN

C  START THE LIST AGAIN WITH THE MISSED NODE

                  CALL MESAGE ('A DISCONTINUITY (SLIDE LINE) IN THE '//
     &               'BODY HAS BEEN FOUND')
                  CALL MESAGE
     &               ('SEPARATE PART NUMBERING WILL ALSO BE OPTIMIZED')
                  NUMA = 1
                  LA(1) = I
                  GO TO 210
               END IF
  250       CONTINUE

C  DEFINITE ERROR IN THE NUMBERING PROCESS

            CALL MESAGE ('ALL NODES COULD NOT BE FOUND TO NUMBER')
            CALL MESAGE ('       *** NO MESH SAVED ***')
            CALL MESAGE ('       ** NUMBERING ABORT **')
            KKK = 0
            RETURN
         END IF

C  PREPARE TO PUT NODE LIST INTO NEWLY DETERMINED ORDER
C  LISTN BECOMES THE POINTER FROM THE OLD NUMBER TO THE NEW

         DO 260 I = 1, NNN
            J = LIST(I)
            LISTN(J) = I
  260    CONTINUE

C  CONVERT NODE NUMBERS TO NEW NODE ORDER BY REDOING THE NXK ARRAY

         DO 280 I = 1, 4
            DO 270 K = 1, KKK
               J = NXK(I, K)
               IF (J .GT. 0) NXK(I, K) = LISTN(J)
  270       CONTINUE
  280    CONTINUE

         IF (NNNBC .GT. 0) THEN
            DO 290 I = 1, NNNBC
               IF (LSTNBC(I) .GT. 0) THEN
                  J = LSTNBC(I)
                  LSTNBC(I) = LISTN(J)
               END IF
  290       CONTINUE
         END IF

C  PUT NODE LIST INTO NEW ORDER

         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)

C  REBUILD KXN ARRAY

         NUMKXN = NNN
         DO 310 I = 1, NNXK
            DO 300 J = 1, MAXKXN
               KXN(I, J) = 0
  300       CONTINUE
  310    CONTINUE

         DO 330 I = 1, 4
            DO 320 K = 1, KKK
               IF (NXK(I, K) .GT. 0) THEN
                  CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K),
     &               ERR)
                  IF (ERR) THEN
                     CALL MESAGE ('** NUMBERING ABORT **')
                     KKK = 0
                     RETURN
                  END IF
               END IF
  320       CONTINUE
  330    CONTINUE

C  PUT ELEMENT NUMBERING INTO NEW ORDER USING LA AS TEMPORARY STORAGE

         DO 340 I = 1, KKK
            LA(I) = 0
            LB(I) = 0
  340    CONTINUE
         KOUNT = 0
         DO 360 I = 1, NNN
            CALL GETKXN (NPNODE, MAXKXN, NNXK, KXN, NUID, I, KLIST,
     &         NUMK, ERR)
            DO 350 J = 1, NUMK
               IF (LB(KLIST(J)) .EQ. 0) THEN
                  KOUNT = KOUNT + 1
                  LA(KOUNT) = KLIST(J)
                  LB(KLIST(J)) = 1
               END IF
  350       CONTINUE
  360    CONTINUE

C  END OF OPTIMIZATION

      ELSE
         DO 370 I = 1, NNN
            NUID(I) = LISTN(I)
  370    CONTINUE
      END IF

C  STICK LSTNBC INTO LISTN AS A WORK ARRAY FOR SORTING NODAL BOUNDARY
C  CONDITIONS LISTS

      IF (NNNBC .GT. 0) THEN
         DO 380 I = 1, NNNBC
            LISTN(I) = LSTNBC(I)
  380    CONTINUE

C  SORT THROUGH LSTNBC AND RECREATE IT IN PLACE
C  USING LISTN AS THE ARRAY TO TAKE LSTNBC OVER
C  AND IHERE AS A WORK ARRAY
C  (LSTNBC NOW BECOMES THE NODES ARRAY FOR THE
C  GENESIS DATA BASE)

         CALL SRTNBC (MXNFLG, NPNBC, NNN, NNFLG, NNLEN, NNPTR, LSTNBC,
     &      LISTN, IHERE, NNNBC, NBCNOD, NNLIST)
      ELSE
         NNLIST = 0
         NBCNOD = 0
      END IF

C  SORT THROUGH LSTSBC AND RECREATE IT IN PLACE
C  USING LISTN AS THE ARRAY TO TAKE LSTSBC OVER
C  AND KXN AS A WORK ARRAY
C  (LSTSBC NOW BECOMES THE NELEMS ARRAY FOR THE
C  GENESIS DATA BASE)

      IF (NNSBC .GT. 0) THEN
         DO 390 I = 1, NNSBC
            LISTN(I) = LSTSBC(I)
  390    CONTINUE

         CALL SRTSBC (MXSFLG, NPSBC, NPELEM, NNXK, NXK, NSFLG, NSLEN,
     &      NSPTR, NVLEN, NVPTR, LISTN, LSTSBC, NSIDEN, IHERE, NNSBC,
     &      NSLIST, NVLIST, NBCSID)

      ELSE
         NBCSID = 0
         NSLIST = 0
         NVLIST = 0
      END IF

C  PUT WEIGHTS ON FLAGGED NODES AS NEEDED
C  USE THE IHERE ARRAY AS A WORK ARRAY

      CALL ADDWT (NNUID, NNXK, MAXKXN, NPNODE, NPELEM, MXLPS, MP, ML,
     &   MS, NPNBC, NPSBC, MXNFLG, MXSFLG, NPWTS, COOR, ILINE, LTYPE,
     &   LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS, IPBF,
     &   NPPF, IFPB, LISTPB, IWTPBF, ILBF, NLPF, IFLB, LISTLB, IWTLBF,
     &   ISBF, NSPF, IFSB, LISTSB, IWTSBF, LINKPB, LINKLB, LINKSB, XN,
     &   YN, NUID, NXK, KXN, LSTNBC, NNFLG, NNPTR, NNLEN, NSFLG, NVPTR,
     &   NVLEN, NSIDEN, WTNODE, WTSIDE, WTHOLD, NBCNOD, NNLIST, NBCSID,
     &   NSLIST, NVLIST, ILIST, XLIST)

C  SORT NUMBERS ACCORDING TO MATERIAL TYPE
C  USE KXN AS A WORK ARRAY

      DO 410 J = 1, 4
         DO 400 I = 1, KKK
            KXN(J, I) = NXK(J, I)
  400    CONTINUE
  410 CONTINUE

C  SET UP THE MATERIAL MAPPING ARRAY
C      MATMAP(1, I) = THE MATERIAL ID FOR THE I'TH BLOCK
C      MATMAP(2, I) = THE FIRST ELEMENT IN THE I'TH BLOCK
C      MATMAP(3, I) = THE LAST ELEMENT IN THE I'TH BLOCK

      KOUNT = 1
      DO 440 I = 1, NUMMAT
         KMAT = MATMAP(1, I)
         MATMAP(2, I) = KOUNT
         DO 430 J = 1, KKK
            IF (MAT(J) .EQ. KMAT) THEN
               LISTN(J) = KOUNT
               LIST(KOUNT) = J
               DO 420 K = 1, 4
                  NXK(K, KOUNT) = KXN(K, J)
  420          CONTINUE
               KOUNT = KOUNT + 1
            END IF
  430    CONTINUE
         MATMAP(3, I) = KOUNT - 1
  440 CONTINUE
      IF (KOUNT - 1 .NE. KKK) THEN
         CALL MESAGE ('ALL ELEMENTS DID NOT HAVE AN ELEMENT ID')
         CALL MESAGE ('MESH NUMBERING ABORTED')
         KKK = 0
         RETURN
      END IF

C  REDO THE REGION POINTER ARRAY

      DO 450 I = 1, NPREGN
         IPART(2, I) = LISTN(IPART(2, I))
         IPART(3, I) = LISTN(IPART(3, I))
  450 CONTINUE

C  REDO THE MATERIAL ARRAY

      DO 470 I = 1, NUMMAT
         DO 460 J = MATMAP(2, I), MATMAP(3, I)
            MAT(J) = MATMAP(1, I)
  460    CONTINUE
  470 CONTINUE

C  REDO THE MAPPING ARRAY IF OPTIMIZING RENUMBERING HAS BEEN DONE

      IF (OPTIM) THEN
         DO 480 I = 1, KKK
            LA(I) = LISTN(LA(I))
  480    CONTINUE
      END IF

C  REDO THE ELEMENT SIDE BOUNDARY LISTING WITH THE CURRENT ELEMENT NO.

      DO 490 I = 1, NSLIST
         LSTSBC(I) = LISTN(LSTSBC(I))
  490 CONTINUE

C  STORE THE LISTN POINTER SYSTEM FOR NOW

      DO 500 I = 1, KKK
         LIST(I) = LISTN(I)
  500 CONTINUE

C  ADD THE MID-SIDE NODES IF EIGHT OR NINE NODE QUADS ARE WANTED
C  OR IF THREE NODE BARS ARE WANTED

      IF ((EIGHT) .OR. (NINE) .OR. (THREE)) THEN

C  FLAG ALL ELEMENT SIDES ONLY ONCE (NO SHARED SIDE FLAGGED)

         CALL NXKBDY (NNXK * MAXKXN, NNXK, NPELEM, NXK, KKK, KXN,
     &      THREE, EIGHT, NINE)

C  CREATE THE MIDSIDE NODES

         CALL MIDNOD (NPNODE, NNUID, NPELEM, NNXK, MP, ML, KKK, NNN,
     &      NALL, NL, NXK, NUID, XN, YN, LISTN, COOR, ILINE, LTYPE,
     &      LCON, LINKP, LINKL, THREE, EIGHT, NINE)

C  MODIFY THE IDENTIFIERS OF THE OLD NODES

         DO 510 I = 1, NNN
            LISTN(I) = I * 100000
  510    CONTINUE
         NNN = NALL

C  ORDER THE EXPANDED NODE LIST

         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)

C  EXPAND THE CONNECTIVITY ARRAY TO INCLUDE THE MIDSIDE NODES
C  WHILE REPOSITIONING THE CORNER NODES INTO PROPER SEQUENCE

         DO 540 I = 1, KKK
            IF ((THREE) .AND. (NXK (3, I) .EQ. 0)) THEN
               ITSOK = .TRUE.
            ELSEIF ((NXK (3, I) .NE. 0) .AND. ((EIGHT) .OR. (NINE)))
     &         THEN
               ITSOK = .TRUE.
            ELSE
               ITSOK = .FALSE.
            ENDIF
            IF (ITSOK) THEN
               DO 520 J = 4, 1, -1
                  JJ = J + 1
                  IF (JJ .EQ. 5) JJ = 1
                  NODEA = IABS(NXK(J, I))
                  NODEB = IABS(NXK(JJ, I))

C  CHECK FOR 3 NODE BAR ELEMENTS

                  IF ((NODEA .GT. 0) .AND. (NODEB .GT. 0)) THEN
                     NXK (J * 2 - 1, I) = NODEA * 100000
                     NLO = MIN0(NODEA, NODEB)
                     NHI = MAX0(NODEA, NODEB)
                     NXK (J * 2, I) = NLO * 100000 + NHI
                  ELSE IF (NODEA .GT. 0) THEN
                     NXK (J * 2 - 1, I) = NODEA * 100000
                  END IF
  520          CONTINUE
            ELSE
               DO 530 J = 1, 4
                  NXK (J, I) = IABS (NXK (J,I)) * 100000
  530          CONTINUE
            ENDIF
  540    CONTINUE

C  GET THE LIST OF NODAL BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS
C  IN PLACE (USE NUID AND WTHOLD AS WORK ARRAYS)

         IF (NBCNOD .GT. 0) THEN
            KOUNT = 0
            DO 570 I = 1, NBCNOD
               JEND = NNLEN(I) + NNPTR(I) - 1
               DO 560 J = NNPTR(I), JEND
                  KOUNT = KOUNT + 1
                  NUID(KOUNT) = LSTNBC(J) * 100000
                  WTHOLD(KOUNT) = WTNODE(J)
                  DO 550 K = J + 1, JEND
                     ILO = MIN0(LSTNBC(J), LSTNBC(K))
                     IHI = MAX0(LSTNBC(J), LSTNBC(K))
                     ITRY = (ILO * 100000) + IHI
                     IF (INDX(NNN, LISTN, ITRY) .GT. 0) THEN
                        KOUNT = KOUNT + 1
                        NNLEN(I) = NNLEN(I) + 1
                        NUID(KOUNT) = ITRY
                        WTHOLD(KOUNT) = (WTNODE(J) + WTNODE(K)) * .5
                     END IF
  550             CONTINUE
  560          CONTINUE
               IF (I .NE. 1) NNPTR(I) = NNPTR(I - 1) + NNLEN(I - 1)
  570       CONTINUE
            NNLIST = KOUNT
            DO 580 I = 1, NNLIST
               LSTNBC(I) = NUID(I)
               WTNODE(I) = WTHOLD(I)
  580       CONTINUE
         END IF

C  GET THE LIST OF SIDE BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS
C  IN PLACE (USE NUID, WTHOLD, AND KXN AS WORK ARRAYS)

         IF (NBCSID .GT. 0) THEN
            KOUNT = 0
            KOUNT2 = 0
            DO 600 I = 1, NBCSID
               ISTART = NSPTR (I)
               IEND = NSPTR (I) + NSLEN (I) - 1
               J = NVPTR (I)
               JEND = NVPTR (I) + NVLEN (I) - 1
               DO 590 II = ISTART, IEND
                  KELEM = LSTSBC (II)
                  KOUNT = KOUNT + 1
                  KXN (1, KOUNT) = KELEM
                  K = J + 1
                  KOUNT2 = KOUNT2 + 1
                  NUID(KOUNT2) = NSIDEN(J) * 100000
                  WTHOLD(KOUNT2) = WTSIDE(J)

C  DO THE ADJUSTMENTS IF THE ELEMENT IS ONE THAT HAS BEEN EXPANDED

                  IF ( ((THREE) .AND. (NXK (4, KELEM) .EQ. 0)) .OR.
     &               ( ((EIGHT) .OR. (NINE)) .AND.
     &               (NXK (4, KELEM) .NE. 0) ) ) THEN
                     KOUNT = KOUNT + 1
                     KXN (1, KOUNT) = LSTSBC(II)
                     NSLEN (I) = NSLEN (I) + 1
                     ILO = MIN0(NSIDEN(J), NSIDEN(K))
                     IHI = MAX0(NSIDEN(J), NSIDEN(K))
                     ITRY = (ILO * 100000) + IHI
                     KOUNT2 = KOUNT2 + 1
                     NUID(KOUNT2) = ITRY
                     WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5
                     KOUNT2 = KOUNT2 + 1
                     NUID(KOUNT2) = ITRY
                     WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5
                     NVLEN(I) = NVLEN(I) + 2
                  ENDIF
                  KOUNT2 = KOUNT2 + 1
                  NUID(KOUNT2) = NSIDEN(K) * 100000
                  WTHOLD(KOUNT2) = WTSIDE(K)
                  J = J + 2
  590          CONTINUE
               IF (I .GT. 1) THEN
                  NSPTR(I) = NSPTR(I - 1) + NSLEN(I - 1)
                  NVPTR(I) = NVPTR(I - 1) + NVLEN(I - 1)
               ENDIF
  600       CONTINUE

C  TRANSFER THE ELEMENT BOUNDARIES BACK FROM THE WORK ARRAYS

            NSLIST = KOUNT
            DO 610 I = 1, NSLIST
               LSTSBC(I) = KXN(1, I)
  610       CONTINUE
            NVLIST = KOUNT2
            DO 620 I = 1, NVLIST
               NSIDEN(I) = NUID(I)
               WTSIDE(I) = WTHOLD(I)
  620       CONTINUE
         END IF

C  ADD A CENTER NODE TO THE NODE LIST IF NEEDED

         IF (NINE) THEN
            NOLD = NNN
            DO 630 I = 1, KKK

C  WATCH OUT FOR 3 NODE BAR ELEMENTS

               IF (.NOT. ISBARS .OR. NXK(4, I) .GT. 0) THEN
                  N2 = INDX(NOLD, LISTN, NXK(2, I))
                  N4 = INDX(NOLD, LISTN, NXK(4, I))
                  N6 = INDX(NOLD, LISTN, NXK(6, I))
                  N8 = INDX(NOLD, LISTN, NXK(8, I))
                  IF ((N2 .EQ. 0) .OR. (N4 .EQ. 0) .OR.
     &               (N6 .EQ. 0) .OR. (N8 .EQ. 0)) THEN
                     CALL MESAGE ('BAD LINK IN RENUM AT 8 NODE LIST')
                     CALL MESAGE ('NO MESH SAVED')
                     KKK = 0
                     RETURN
                  END IF
                  DIST1 = SQRT((XN(N2) - XN(N6)) **2
     &               + (YN(N2) - YN(N6)) **2)
                  DIST2 = SQRT((XN(N8) - XN(N4)) **2
     &               + (YN(N8) - YN(N4)) **2)
                  NNN = NNN + 1
                  IF (DIST1 .LT. DIST2) THEN
                     XN(NNN) = .5 * (XN(N2) + XN(N6))
                     YN(NNN) = .5 * (YN(N2) + YN(N6))
                  ELSE
                     XN(NNN) = .5 * (XN(N4) + XN(N8))
                     YN(NNN) = .5 * (YN(N4) + YN(N8))
                  END IF
                  LISTN(NNN) = INT((MIN0(NXK(1, I), NXK(5, I))) +
     &               (MAX0(NXK(1, I), NXK(5, I)) * .0001))
                  NXK(9, I) = LISTN(NNN)
                ELSE
                  write (*,*) 'Element ', i, ' is a 3-node bar?'
               END IF
  630       CONTINUE

C  NOW, ORDER THE EXPANDED NODE LIST AGAIN

            CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)
            IEND = 9
         ELSEIF (EIGHT) THEN
            IEND = 8
         ELSE
            IEND = 4
         END IF

C  NOW REPLACE THE NODE REFERENCES WITH AN EXPANDED ORDER NUMBER

C  FIRST FIX THE CONNECTIVITY (NXK ARRAY)

         DO 650 I = 1, IEND
            DO 640 K = 1, KKK

C  AGAIN, WATCH OUT FOR 3 NODE BAR ELEMENTS

               IF (.NOT. ISBARS .OR. NXK(I, K) .GT. 0) THEN
                  NEW = INDX(NNN, LISTN, NXK(I, K))
                  IF (NEW .EQ. 0) THEN
                     CALL MESAGE ('BAD LINK IN RENUM 8 NODE LIST')
                     CALL MESAGE ('NO MESH SAVED')
                     KKK = 0
                     RETURN
                  END IF
                  NXK(I, K) = NEW
               END IF
  640       CONTINUE
  650    CONTINUE

C  NOW FIX THE NODE BOUNDARY FLAGS

         IF (NBCNOD .GT. 0) THEN
            DO 660 I = 1, NNLIST
               NEW = INDX(NNN, LISTN, LSTNBC(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESAGE ('BAD LINK IN RENUM AT 8 NODE NBC')
                  CALL MESAGE ('NO MESH SAVED')
                  KKK = 0
                  RETURN
               END IF
               LSTNBC(I) = NEW
  660       CONTINUE
         END IF

C  NOW FIX THE SIDE BOUNDARY FLAGS

         IF (NBCSID .GT. 0) THEN
            DO 670 I = 1, NVLIST
               NEW = INDX(NNN, LISTN, NSIDEN(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESAGE ('BAD LINK IN RENUM AT 8 NODE SBC')
                  CALL MESAGE ('NO MESH SAVED')
                  KKK = 0
                  RETURN
               END IF
               NSIDEN(I) = NEW
  670       CONTINUE
         END IF
      END IF

C  RENUMBERING COMPLETED

      CALL MESAGE (' ')
      CALL MESAGE ('**************************************************')
      CALL MESAGE ('**           MESH PROCESSING COMPLETED          **')
      IF (ISBARS .AND. NINE) THEN
         CALL MESAGE ('**            THREE NODE BARS OUTPUT         '//
     &      '   **')
      ENDIF
      IF (NINE) THEN
         CALL MESAGE ('**            NINE NODE QUADS OUTPUT         '//
     &      '   **')
      ELSE IF (EIGHT) THEN
         CALL MESAGE ('**           EIGHT NODE QUADS OUTPUT         '//
     &      '   **')
      END IF
      IF (OPTIM) THEN
         CALL MESAGE
     &      ('**   WITH NODE AND ELEMENT NUMBERING OPTIMIZED  **')

C  FIND LARGEST NODE DIFFERENCE FOR AN ELEMENT

         LWID = 0
         DO 680 K = 1, KKK
            N1 = NXK(1, K)
            N2 = NXK(2, K)
            N3 = NXK(3, K)
            N4 = NXK(4, K)
            IF ((N4 .GT. 0) .AND. ((EIGHT) .OR. (NINE))) THEN
               N5 = NXK(5, K)
               N6 = NXK(6, K)
               N7 = NXK(7, K)
               N8 = NXK(8, K)
               IF (NINE) THEN
                  N9 = NXK(9, K)
                  NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8, N9)
                  NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8, N9)
               ELSE
                  NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8)
                  NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8)
               END IF
            ELSE
               IF (N3 .LE. 0) N3 = N1
               IF (N4 .LE. 0) N4 = N2
               NLO = MIN0(N1, N2, N3, N4)
               NHI = MAX0(N1, N2, N3, N4)
            END IF
            LWID = MAX0(LWID, NHI - NLO)
  680    CONTINUE
         WRITE(*, 10000) LWID
      END IF
      WRITE(*, 10010) NNN, KKK, NUMMAT
      CALL MESAGE ('**************************************************')

C  RESTORE THE NUID ARRAY AS A POINTER ARRAY OF OLD TO NEW ELEMENTS
C  (MAPDXG ARRAY)

      IF (OPTIM) THEN
         DO 690 I = 1, KKK
            NUID(I) = LA(I)
            LIST(NUID(I)) = I
  690    CONTINUE
      ELSE
         DO 700 I = 1, KKK
            NUID(I) = I
            LIST(I) = I
  700    CONTINUE
      END IF

      RETURN

10000 FORMAT(' **   LARGEST NODE DIFFERENCE PER ELEMENT:', I6, '  **')
10010 FORMAT(' ** NODES:', I6, '; ELEMENTS:', I6, '; MATERIALS:', I3,
     &   ' **')

      END


	SUBROUTINE DC_GTIM  ( isdtar, btime, irhour, irmin, offtim,
     +			      irdtar, rtime, iret )
C************************************************************************
C* DC_GTIM								*
C*									*
C* This subroutine combines an integer system time, the bulletin	*
C* time containing the day, month and hour and the report day and	*
C* hour into an observation time.  It is assumed that the system	*
C* time accurately reflects the year and month of the observation	*
C* and is later than that time.						*
C*									*
C* DC_GTIM  ( ISDTAR, BTIME, IRHOUR, IRMIN, OFFTIM, IRDTAR, RTIME,	*
C*	      IRET )							*
C*									*
C* Input parameters:							*
C*	ISDTAR (5)	INTEGER		System time			*
C*	BTIME		CHAR*		Bulletin day, hour, minute	*
C*	IRHOUR		INTEGER		Report hour			*
C*	IRMIN		INTEGER		Report minute			*
C*	OFFTIM		LOGICAL		Flag for decoding off-time rpts	*
C*									*
C* Output parameters:							*
C*	IRDTAR (5)	INTEGER		Integer report time		*
C*	RTIME		CHAR*		Report date/time		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-15 = rpt/bultn time discrepancy*
C*					-16 = invalid time		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 4/90						*
C* J. Whistler/SSAI	 4/91	Subtract 24 from ibhour when > 24	*
C* J. Whistler/SSAI	 7/91	Changed iyear to ioyear where mistyped	*
C* S. Jacobs/NCEP	 1/96	Changed minute check from >45 to >=45	*
C* S. Jacobs/NCEP	 7/96	Added check for return from TI_ITOC	*
C* K. Tyle/GSC		 1/97	Added check for return from TI_ITOC (2)	*
C* D. Kidwell/NCEP	 4/98	Added store to irdtar when btime is ' ' *
C* D. Kidwell/NCEP	 9/98	Fixed bugs in month, year changeovers   *
C* F. J. Yen/NCEP	 6/99	Renamed from RA_RTIM; Handled off-time	*
C*				reports & used return codes for dc.err	*
C* D. Kidwell/NCEP	 9/02	Added store to irdtar when iret is -15  *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		isdtar (*), irdtar (*)
	CHARACTER*(*)	btime, rtime
C*
	LOGICAL		subday, addday, offtim
C*
	INTEGER		iodtar (5)
	EQUIVALENCE	( iodtar (1), ioyear ), ( iodtar (2), iomnth ),
     +			( iodtar (3), ioday  ), ( iodtar (4), iohour ),
     +			( iodtar (5), iomin  )
C------------------------------------------------------------------------
	iret   = 0
	addday = .false.
	subday = .false.
C
C*	Set minutes for GEMPAK time depending on whether off-time
C*	reports are to be decoded.  Currently a maximum of 2
C*	off-time reports are allowed.
C
	IF ( offtim ) THEN
	    IF ( irmin .ge. 45 .or. irmin .lt. 5 ) THEN
		iomin = 0
	      ELSE
	 	IF ( irmin .ge. 5 .and. irmin .lt. 25 ) THEN
		    iomin = 20
		  ELSE
		    iomin = 40
		END IF
	    END IF
	  ELSE
	    iomin = 0
	END IF
C
C*	Use the system time for the observation time for the year and
C*	month.
C
	ioyear = isdtar (1)
	iomnth = isdtar (2)
C
C*	If no bulletin time was sent, use day from system time and
C*	hour from report time.
C
	IF  ( btime .eq. ' ' )  THEN
	    ioday  = isdtar (3)
C
C*	    Get correct hour depending on the minutes on the report.
C
	    IF  ( irmin .ge. 45 )  THEN
		iohour = irhour + 1
	      ELSE
		iohour = irhour
	    END IF
	    IF  ( iohour .ge. 24 )  iohour = iohour - 24
	    IF  ( iohour .gt. isdtar (4) )  THEN
		CALL TI_SUBD  ( iodtar, iodtar, ier )
	    END IF
C
C*	    Get full time.
C
	    CALL TI_ITOC  ( iodtar, rtime, ierr )
	    IF  ( ierr .ne. 0 )  iret = -16
	    DO  i = 1, 5
		irdtar (i) = iodtar (i)
	    END DO
	  ELSE
C
C*	    Get the day, hour and minute from the bulletin.
C
	    CALL ST_INTG  ( btime (1:2), ioday,  ier )
	    CALL ST_INTG  ( btime (3:4), ibhour, ier )
	    CALL ST_INTG  ( btime (5:6), ibmin,  ier )
	    IF  ( ibmin .ge. 45 )  THEN
		ibhour = ibhour + 1
		IF  ( ibhour .ge. 24 )  THEN
		    ibhour = ibhour - 24
		    addday = .true.
		END IF
	    END IF
C
C*	    Get the hour from the report time.
C
	    iohour = irhour
	    IF  ( irmin .ge. 45 )  THEN
		iohour = iohour + 1
		IF  ( iohour .ge. 24 )  iohour = iohour - 24
	    END IF
C
C*	    Make sure the report and bulletin time are within one hour.
C
	    ihdiff = ABS  ( ibhour - iohour )
	    IF  ( ihdiff .le. 1 )  THEN
C
C*		This report is ok.
C
	      ELSE IF  ( ( iohour .eq. 0 ) .and. ( ibhour .eq. 23 ) )
     +								THEN
		addday = .true.
	      ELSE IF  ( ( iohour .eq. 23 ) .and. ( ibhour .eq. 0 ) )
     +								THEN
		subday = .true.
	      ELSE
C
C*		Bulletin and report time do not match.
C
		iret  = -15
		rtime = ' '
	        DO  i = 1, 5
		    irdtar (i) = iodtar (i)
	        END DO
		RETURN
	    END IF
C
C*	    Check that the month has not changed.
C
	    IF  ( ( isdtar (3) .eq. 1 ) .and. ( iodtar (3) .gt. 27 ) )
     +								THEN
		iomnth = iomnth - 1
		IF  ( iomnth .eq. 0 )  THEN
		    iomnth = 12
		    ioyear = ioyear - 1
		END IF
	      ELSE IF  ( ( isdtar (3) .gt. 27 ) .and.
     +			 ( iodtar (3) .eq. 1 ) )  THEN
		iomnth = iomnth + 1
		IF  ( iomnth .eq. 13 )  THEN
		    iomnth = 1
		    ioyear = ioyear + 1
		END IF
	    END IF
C
C*	    Add or subtract days if necessary.
C
	    IF  ( subday )  CALL TI_SUBD  ( iodtar, iodtar, ier )
	    IF  ( addday )  CALL TI_ADDD  ( iodtar, iodtar, ier )
C
C*	    Convert to a GEMPAK time.
C
	    CALL TI_ITOC  ( iodtar, rtime, ierr )
	    IF ( ierr .ne. 0 ) iret = -16
	    DO  i = 1, 5
		irdtar (i) = iodtar (i)
	    END DO
	END IF
C*
	RETURN
	END


      subroutine ther_meth_h2o(iflg,ndummy)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To calculate the equation coeffients and derivatives for a
!D1 h2o-methane simulation.
!D1 solid-liquid-gas system.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.20
!D2
!D2 Initial implementation: Date 01-June-02, Programmer: George Zyvoloski
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************

      use comrxni
      use comii
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      use commeth
      implicit none

      integer ndummy,iieosl,mid,mi,ieosd,kq
      real*8 dtin,dporpl,dportl,xrl,xrv,drl,drv,drlp,drvp,ela0,elpa1
      real*8 elpa2,elpa3,elta1,elta2,elta3,elpta,elp2ta,elpt2a
      real*8 elb0,elpb1,elpb2,elpb3,eltb1,eltb2,eltb3,elptb
      real*8 elp2tb,elpt2b,dla0,dlpa1,dlpa2,dlpa3,dlta1,dlta2,dlta3
      real*8 dlpta,dlp2ta,dlpt2a,dlb0,dlpb1,dlpb2,dlpb3,dltb1,dltb2
      real*8 dltb3,dlptb,dlp2tb,dlpt2b,vla0,vlpa1,vlpa2,vlpa3,vlta1
      real*8 vlta2,vlta3,vlpta,vlp2ta,vlpt2a,vlb0,vlpb1,vlpb2,vlpb3
      real*8 vltb1,vltb2,vltb3,vlptb,vlp2tb,vlpt2b,eva0,evpa1,evpa2
      real*8 evpa3,evta1,evta2,evta3,evpta,evp2ta,evpt2a,evb0,evpb1
      real*8 evpb2,evpb3,evtb1,evtb2,evtb3,evptb,evp2tb,evpt2b,dva0
      real*8 dvpa1,dvpa2,dvpa3,dvta1,dvta2,dvta3,dvpta,dvp2ta,dvpt2a
      real*8 dvb0,dvpb1,dvpb2,dvpb3,dvtb1,dvtb2,dvtb3,dvptb,dvp2tb
      real*8 dvpt2b,vva0,vvpa1,vvpa2,vvpa3,vvta1,vvta2,vvta3,vvpta
      real*8 vvp2ta,vvpt2a,vvb0,vvpb1,vvpb2,vvpb3,vvtb1,vvtb2,vvtb3
      real*8 vvptb,vvp2tb,vvpt2b,tl,pl,x,x2,x3,x4,dpsatt,tl2,tl3
      real*8 tlx,tl2x,tlx2,enwn1,enwn2,enwn3,enwn,enwd1,enwd2,enwd3
      real*8 enwd,enw,enl,dhwpn1,dhwpn2,dhwpn,dhwpd,dhwp,dhwtn1
      real*8 dhwtn2,dhwtn,dhwtd,dhwt,dhlt,dhlp,rnwn1,rnwn2,rnwn3
      real*8 rnwd1,rnwd2,rnwd3,rnwn,rnwd,rnw,rol,drlpn1,drlpn2
      real*8 drlpn,drolpd,drolp,drlen1,drlen2,drlen,droled,drolt,viln1
      real*8 viln2,viln3,viln,vild1,vild2,vild3,vild,vil,xvisl
      real*8 dvlpn1,dvlpn2,dvlpn,dvilpd,dvislp,dvlen1,dvlen2,dvlen
      real*8 dviled,dvislt,ensn1,ensn2,ensn3,ensn,ensd1,ensd2,ensd3
      real*8 ensd,ens,env,dhvp1,dhvp2,dhvpn,dhvpd,dhvt1,dhvt2
      real*8 dhvtn,dhvtd,dhvt,dhvp,rnsn1,rnsn2,rnsn3,rnsd1,rnsd2
      real*8 rnsd3,rnsn,rnsd,rns,rov,drspn1,drspn2,drspn,drospd
      real*8 drsen1,drsen2,drsen,drostd,visn1,visn2,visn3,visn,visd1
      real*8 visd2,visd3,visd,vis,xvisv,dvspn1,dvspn2,dvspn,dvispd
      real*8 dvisvp,dvsen1,dvsen2,dvsen,dvised,dvisvt,dtd,sl,qdis
      real*8 cp,por,vol,pldif,permsd,eskd,eqdum,rag,sig,dtrdp,dtrdt
      real*8 rop,rop1,damp,daep,daep1,damh,daeh,dragp,dsigp,dsige
      real*8 den1,roe,dql,hprod,dhprdp,dhprde,htc,tbound,hflux
      real*8 dhflxp,sbound,cprd,edif,denrd,vfd,rl,dvfp,tfun
      real*8 tfunn,tfund,dtpsn,dtpsd,dpldt,dpld3,psat,vfcal,rop2,daep2
      real*8 dqv,dhflxe,dtps,drovp,drovt
      real*8 dhflxem,dhflxpm
      real*8, allocatable :: sto1(:)

      real*8 psatd
      real*8 dum1,dum2,dum3,dum4,dum5,dum6
      real*8 frac_meth,frac_w,dfrac_w,dfrac_methm
      real*8 damm,daem,dsigm,drvm,drlm,dhprdm
      real*8 damw,daew,dsigw,drvw,drlw,dhprdw
      real*8 dhflxew,frac_g,dfrac_gm,dfrac_gw
      real*8 frac_hyd,dfrac_hyd
      real*8 dskhydp,dskhydt,dskhydw,dskhydm
      real*8 dqhhydp,dqhhydt,dqhhydw,dqhhydm
      real*8 fracmb,methterm
      real*8 cden_correction, cden_cor
c
c     gaz took it out of loop (can be specified source as well)
c     will over-ride above methane production
c

      real*8 rlwm,drlwm3,drlwm4,drlwmp,drlwmt
      real*8 rgwm,drgwm3,drgwm4,drgwmp,drgwmt
      real*8 prf,dprf4
      real*8 prodfac,dprodfac3,dprodfac4,fracwmin

      parameter (fracwmin=0.1)
      integer idum,iflg

      allocate(sto1(n0*2))
c
c     rol  -  density liquid
c     rov  -  density vapour
c     enl  -  enthalpy liquid
c     env  -  enthalpy vapour
c     visl -  viscosity of liquid
c     visv -  viscosity of vapour
c     rl   -  relative permeability of liquid phase
c     rv   -  relative permeability of vapour phase
c     tfun -  temperature
c     sw   -  saturation liquid
c
      dtin=1.0/dtot

c     ****************************************************************
      if(iflg.eq.0) then
c     calculations that are common to methane,methane hydrate, and water
c     calculate pressure dependant porosity and derivatives

         if(iporos.ne.0) call porosi(1)
c     new cappilary pressure routine
         call cappr_hyd(1,0)

         allocate(rl_meth(n0))
         allocate(drl_meth3(n0))
         allocate(drl_meth4(n0))
         allocate(rl_h2o(n0))
         allocate(drl_h2o3(n0))
         allocate(drl_h2o4(n0))
         rl_h2o = 0.0
         rl_meth = 0.0

         drl_meth3 = 0.0
         drl_meth4 = 0.0
         drl_h2o3 = 0.0
         drl_h2o4 = 0.0

         do mid=1,neq
            mi=mid+ndummy
            call rlperm_hyd(ndummy,0,mi,rl_h2o(mi),0.0,0.0,
     &           drl_h2o3(mi),drl_h2o4(mi),rl_meth(mi),
     &           0.0,0.0,drl_meth3(mi),drl_meth4(mi))

         enddo

c
c     ****************************************************************
      else if(iflg.eq.-1) then
c     release memory

         deallocate(rl_meth)
         deallocate(drl_meth3)
         deallocate(drl_meth4)
         deallocate(rl_h2o)
         deallocate(drl_h2o3)
         deallocate(drl_h2o4)

c     ****************************************************************
      else if(iflg.eq.1) then
c     calculations for water

         iieosl=0
         drvw = 0.0
         drlw = 0.0
         drvm = 0.0
         do mid=1,neq
            mi=mid+ndummy
c     phase information now contained in array ices
            ieosd=ieos(mi)

            pl=phi(mi)
            sl=s(mi)

c
c     term to account for space taken up with water
c
            frac_w = fracw(mi)
            frac_hyd  = frachyd(mi)
            dfrac_w = 1.0
            dfrac_hyd = -1.0
            if(ieosd.eq.2) then

c     two phase (gas/liquid) conditions
c     calculate relative permeabilities of vapor-liquid

               call h2o_properties(6,1,dum1,dum2,sl,dum3,
     &              pcp(mi),dum4,dpcef(mi),dum5,dum6)

c     calculate relative permeabilities of vapor-liquid

               call h2o_properties(7,1,dum1,dum2,sl,dum3,
     &              rvf(mi),drvpf(mi),drvef(mi),dum5,dum6)
               xrv=rvf(mi)
               drv=drvef(mi)
               drvp=drvpf(mi)

               call h2o_properties(7,2,dum1,dum2,sl,dum3,
     &              rlf(mi),drlpf(mi),drlef(mi),dum5,dum6)
               xrl=rlf(mi)
               drl=drlef(mi)
               drlp=drlpf(mi)
            endif

            if(ieosd.eq.-2) then

c     two phase (liquid/solid) conditions
c     calculate relative permeabilities of vapor-liquid
c     rvf now containes the solid relative permeability

               call h2o_properties(6,2,dum1,dum2,sl,dum3,
     &              pcp(mi),dum4,dpcef(mi),dum5,dum6)

c     calculate relative permeabilities of vapor-liquid

               call h2o_properties(8,1,dum1,dum2,sl,dum3,
     &              rvf(mi),drvpf(mi),drvef(mi),dum5,dum6)
               xrv=rvf(mi)
               drv=drvef(mi)
               drvp=drvpf(mi)

               call h2o_properties(8,2,dum1,dum2,sl,dum3,
     &              rlf(mi),drlpf(mi),drlef(mi),dum5,dum6)
               xrl=rlf(mi)
               drl=drlef(mi)
               drlp=drlpf(mi)
            endif

            if(ieosd.eq.2) then

c     two phase (gas/liquid) conditions

c     calculate phase-change temperature and dt/dp
               call h2o_properties(4,2,pl,dum1,dum2,dum3,
     &              tl,dtps,dum4,dum5,dum6)
c     calculate phase-change pressure and dp/dt
               call h2o_properties(5,2,tl,dum1,dum2,dum3,
     &              psatd,dum4,dpsatt,dum5,dum6)
c
            else if(ieosd.eq.-2) then

c     two phase (liquid/solid) conditions

c     calculate temperature and dt/dp
               call h2o_properties(4,1,pl,dum1,dum2,dum3,
     &              tl,dtps,dum4,dum5,dum6)
c     calculate pressure  and dp/dt
               call h2o_properties(5,1,tl,dum1,dum2,dum3,
     &              psatd,dum4,dpsatt,dum5,dum6)
            else
               tl=t(mi)
            endif
            if(abs(ieosd).ne.3) then

c     liquid enthalpy and derivatives

               call h2o_properties(1,2,pl,tl,dum2,dum3,
     &              enl,dhlp,dhlt,dum5,dum6)

c     liquid density and derivatives

               call h2o_properties(2,2,pl,tl,dum2,dum3,
     &              rol,drolp,drolt,dum5,dum6)

c     modify density(explicit update) if it changes with concentration
               if(cden) then
c     Add correction for liquid species
                  cden_cor = cden_correction(mi)
                  rol = rol + cden_cor
               end if

c     liquid viscosity and derivatives

               call h2o_properties(3,2,pl,tl,dum2,dum3,
     &              xvisl,dvislp,dvislt,dum5,dum6)

            endif

            if(ieosd.ge.2) then

c     vapor enthalpy and derivatives

               call h2o_properties(1,3,pl,tl,dum2,dum3,
     &              env,dhvp,dhvt,dum5,dum6)

c     vapor density and derivatives

               call h2o_properties(2,3,pl,tl,dum2,dum3,
     &              rov,drovp,drovt,dum5,dum6)

c     vapor viscosity and derivatives

               call h2o_properties(3,3,pl,tl,dum2,dum3,
     &              xvisv,dvisvp,dvisvt,dum5,dum6)

            endif
            if(ieosd.le.-2) then

c     properties of solid phase
c     properties of solid phase will be put into variables for vapor
c     it is assumed that solid and vapor can not exist simultaneously at the same node

c     calculate solid enthalpy and derivative wrt p and t

               call h2o_properties(1,1,pl,tl,dum2,dum3,
     &              env,dhvp,dhvt,dum5,dum6)

c     calculate solid density and derivative wrt p and t

               call h2o_properties(2,1,pl,tl,dum2,dum3,
     &              rov,drovp,drovt,dum5,dum6)

c     calculate solid viscosity (should be very large!) and derivative wrt p and t
c     should be zero

               call h2o_properties(3,1,pl,tl,dum2,dum3,
     &              xvisv,dvisvp,dvisvt,dum5,dum6)

            endif
c     calculate special capillary pressure as a function of water frac
c     gaz 1-12-04 implemented cappr_hyd
c     call h2o_properties(10,1,frac_w,tl,dum2,dum3,
c     &                              pcpmeth(mi),dpcefmeth(mi),
c     &                              dum4,dum5,dum6)
c     gaz 12-24-03
c     calculate special relative permeability for liquid water-methane gas
c
c     call h2o_properties(11,1,pl,tl,frac_w,dum2,
c     &                              rlwm,drlwmp,drlwmt,drlwm3,dum6)
            rlwm = rl_h2o(mi)
            drlwm3 = drl_h2o3(mi)
            drlwm4 = drl_h2o4(mi)
            drlwmp = 0.0
            drlwmt = 0.0

c     calculate solid gas generation term and derivative wrt p and t and frachyd
c     kinetic approach (note call to hydrate properties)
c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(3,1,pl,tl,fracw(mi),frachyd(mi),
     &           skhyd(mi),dskhydp,dskhydt,dskhydw,dskhydm)
c
c     save rate and derivatives for enthalp calculation (passed through commeth)
c

            source_hyd_temp = skhyd(mi)
            ds1_tmp = dskhydp
            ds2_tmp = dskhydt
            ds3_tmp = dskhydw
            ds4_tmp = dskhydm

c     calculate solid gas heat generation term and derivative wrt p and t and frachyd
c     kinetic approach
c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(4,1,pl,tl,fracw(mi),frachyd(mi),
     &           qhhyd(mi),dqhhydp,dqhhydt,dqhhydw,dqhhydm)

c     form dissociation flow term

            skwhyd(mi) = -ratw*skhyd(mi)

c     load water generation term derivatives

	    dskhyd1(mi) = -ratw*dskhydp
	    dskhyd2(mi) = -ratw*dskhydt
	    dskhyd3(mi) = -ratw*dskhydw
	    dskhyd4(mi) = -ratw*dskhydm

c     modify derivatives for 2-phase (should now depend on p, not t)
            if(abs(ieosd).eq.2) then
               drolp=drolp+drolt*dtps
               drovp=drovp+drovt*dtps
               dhlp=dhlp+dhlt*dtps
               dhvp=dhvp+dhvt*dtps
               dvisvp=dvisvp+dvisvt*dtps
               dvislp=dvislp+dvislt*dtps
               drolt=0.0
               drovt=0.0
               dhlt=0.0
               dhvt=0.0
               dvisvt=0.0
               dvislt=0.0
               dtd=1.0
            endif

            dq(mi)=0.0
            qh(mi)=0.0
            dqh(mi)=0.0
            deqh(mi)=0.0
            deqw(mi)=0.0
            deqpw(mi)=0.0
            dqt(mi)=0.0
            qdis=sk(mi)
            cp=denr(mi)*cpr(mi)
            por=ps(mi)
            dporpl=dporp(mi)
            dportl=dport(mi)
            kq=ka(mi)
            vol=volume(mi)

            if(kq.lt.0) then
c     form pressure dependent flow term
               qh(mi)=0.
               sk(mi)=0.0
               if(pflow(mi).gt.0.0) then
                  pldif=pl-pflow(mi)
                  dpldt=0.0
               else
                  pldif=pl-(psatd-pflow(mi))
                  dpldt=-dpsatt
               endif
               permsd=wellim(mi)
               if(pldif.le.0.0d00.and.kq.eq.-2) permsd=0.
c     changed by rajesh to account for water fraction
c     qdis=permsd*(pldif)
c     dq(mi)=permsd
c     sk(mi)=qdis
c
               qdis=permsd*rlwm*pldif
               sk(mi)=qdis
               dq(mi)=permsd*rlwm+drlwmp*permsd*pldif
               dq3(mi)=permsd*(pldif*drlwm3)
               dq4(mi)=permsd*(pldif*drlwm4)
               if(qdis.le.0.) then
                  eskd=eflow(mi)
                  qh(mi)=eskd*qdis
                  sk(mi)=qdis
                  dqh(mi)=eskd*dq(mi)
               endif
               dqt(mi)=permsd*(dpldt*rlwm+pldif*drlwmt)
            endif
c
c     two phase conditions
            if(abs(ieosd).eq.2) then
c     saturation and relative permeabilities
               sv=1.d0-sl
c     accumulation terms
c     note new terms for fraction of water
               den=por*(sl*rol+sv*rov)*frac_w
               eqdum=(sl*rol*enl+sv*rov*env-pl)*frac_w
               dene=((1.-por)*cp*tl+por*eqdum)
c     production of steam
c     note xrv and xrl now also depend on frac_w
c     xrv and xrl dependence on frac_w not implemented yet
               rag=rol*xvisv/rov/xvisl
               sig=xrv/(xrv+rag*xrl)
c     derivatives of accumulation terms
               rop=por*(sv*drovp+sl*drolp)*frac_w
               damp =rop*dtin
               daep =((1.d0-por)*cp*dtps+por*frac_w*(sv*drovp*env+
     &              sv*rov*dhvp+sl*drolp*enl+sl*rol*dhlp)-por)*dtin
               damh =por*frac_w*(rol-rov)*dtin
               daeh =por*frac_w*(rol*enl-rov*env)*dtin
c     add derivative wrt methane fraction
               damw=por*(sl*rol+sv*rov)*dfrac_w
               daew=por*(sl*rol*enl+sv*rov*env-pl)*dfrac_w
               damm=por*(sl*rol+sv*rov)*dfrac_hyd
               daem=por*(sl*rol*enl+sv*rov*env-pl)*dfrac_hyd
c     derivatives of sink terms
               if(qdis.gt.0.0) then
                  dragp=(rov*xvisl*(drolp*xvisv+rol*dvisvp)-rol*
     2                 xvisv*(drovp
     3                 *xvisl+rov*dvislp))/(xvisl*rov)**2
                  if(sig.ne.0.d0.and.sig.ne.1.d0) then
                     dsigp=-xrv*dragp*xrl/(xrv+rag*xrl)**2
                     dsige=((xrv+rag*xrl)*drv-xrv*(drv+rag*drl))
     3                    /(xrv+rag*xrl)**2
                     dsigw=((xrv+rag*xrl)*drvw-xrv*(drvm+rag*drlw))
     3                    /(xrv+rag*xrl)**2
                  else
                     dsigp=0.d0
                     dsige=0.d0
                     dsigw=0.d0
                  end if
               end if
            end if

c     compressed liquid
            if(ieosd.eq.1) then
               xrl=1.0
               xrv=0.0
               drl=0.0
               drv=0.0
               dtps=0.0
               sl=1.d0
               sv=0.0
               sig=0.d0
               rov=0.d0
               env=0.d0
               drovp=0.0
               drovt=0.0
               dhvp=0.0
               dhvt=0.0
               dvisvp=0.0
               dvisvt=0.0
               dtd=1.0
               xvisv=1.d20

c     accumulation terms
               den=rol*por*frac_w
               dene=(1.d0-por)*cp*tl+por*(rol*enl-pl)*frac_w

c     derivatives of accumulation terms
               damp=(rol*dporpl+por*drolp)*dtin*frac_w
               damw=rol*por*dtin*dfrac_w
c     damm=rol*por*dtin*dfrac_hyd
               damm=0.0
               daep1=(dporpl*rol*enl+por*drolp*enl+por*rol*dhlp
     &              -dporpl*pl-por)*frac_w
c     gaz corrected (rajesh found) 12-17-03
c     daep2=-dporpl*cp*tl*frac_w
               daep2=-dporpl*cp*tl
               daep=(daep1+daep2)*dtin
               damh=(dportl*rol+por*drolt)*dtin*frac_w
               daeh=(-dportl*cp*tl+(1.-por)*cp+(dportl*(enl*rol-pl)+
     &              por*(rol*dhlt+enl*drolt))*frac_w)*dtin
               daew=por*(rol*enl-pl)*dtin*dfrac_w
c     daem=por*(rol*enl-pl)*dtin*dfrac_hyd
               daem=0.0
            end if

c     superheated vapour
            if(abs(ieosd).eq.3) then
               dtps=0.0
               xrl=0.0
               xrv=1.0
               drl=0.0
               drv=0.0
               sl=0.d0
               sv=1.d0
               sig=1.d0
               rol=0.d0
               enl=0.d0
               drolp=0.0
               drolt=0.0
               dhlp=0.0
               dhlt=0.0
               dvislp=0.0
               dvislt=0.0
               dtd=1.0
               xvisl=1.d20

c     accumulation terms
               den=rov*por*frac_w
               dene=(1.d0-por)*cp*tl+por*(rov*env-pl)*frac_w

c     derivatives of accumulation terms
               damp=(dporpl*rov+por*drovp)*dtin*frac_w
               damw=rov*por*dtin*dfrac_w
               damm=rov*por*dtin*dfrac_hyd
               daep1=(dporpl*rov*env+por*drovp*env+por*rov*dhvp
     &              -dporpl*pl-por)*frac_w
               daep2=-dporpl*cp*tl
               daep=(daep1+daep2)*dtin
               damh=(dportl*rov+por*drovt)*dtin*frac_w
               daeh=(-dportl*cp*tl+(1.-por)*cp+(dportl*(env*rov-pl)+
     &              por*(rov*dhvt+env*drovt))*frac_w)*dtin
               daew=por*(rov*env-pl)*dtin*dfrac_w
               daem=por*(rov*env-pl)*dtin*dfrac_hyd
            end if
            if(ps(mi).ne.0.0) then

c     store derivatives of accumulation terms
               dmef(mi)=damh
               dmpf(mi)=damp
               dmmf(mi)=damm
               dmwf(mi)=damw
               depf(mi)=daep
               deef(mi)=daeh
               dewf(mi)=daew
               demf(mi)=daem
               dtpa(mi)=dtps
               dtpae(mi)=dtd
               t(mi)=tl
               s(mi)=sl

c     save accumulation terms for possible volume changes
               sto1(mi)=den
               sto1(mi+neq)=dene
               dstm(mi)=por*rov*sv*vol
               dil(mi)=0.0
               dilp(mi)=0.0
               dile(mi)=0.0
               dilw(mi)=0.0
               dilm(mi)=0.0
               div(mi)=0.0
               divp(mi)=0.0
               dive(mi)=0.0
               divw(mi)=0.0
               divm(mi)=0.0

c     permeability reduction factor

               prf = permhyd(mi)
               dprf4 = dpermhyd4(mi)

               if(abs(ieosd).ne.3) then

c     modify flow terms for new upwind scheme
c     note rlwm used for both phases of methane
                  dql=prf*rlwm*rol*xrl/xvisl
                  dil(mi)=dql
                  dilp(mi)=prf*rlwm*(drolp*xrl/xvisl-
     &                 rol*xrl/xvisl**2*dvislp+rol*drlp/xvisl)
                  dile(mi)=prf*rlwm*(drolt*xrl/xvisl+rol*drl/xvisl
     &                 -rol*xrl/xvisl**2*dvislt)
                  dilw(mi)=prf*rlwm*rol*drlw/xvisl+
     &                 prf*drlwm3*rol*xrl/xvisl
                  dilm(mi)=dprf4*rol*xrl/xvisl
               endif
               dglp(mi)=drolp
               dgle(mi)=drolt
               enlf(mi)=enl
               delf(mi)=dhlp
               delef(mi)=dhlt

c     modify flow terms for new upwind scheme
               if(ieosd.ne.1) then
                  dqv=prf*rlwm*rov*xrv/xvisv
                  div(mi)=dqv
                  divp(mi)=prf*rlwm*(drovp*xrv/xvisv-
     &                 rov*xrv/xvisv**2*dvisvp+rov*drvp/xvisv)
                  dive(mi)=prf*rlwm*(drovt*xrv/xvisv+rov*drv/xvisv
     &                 -rov*xrv/xvisv**2*dvisvt)
                  divw(mi)=prf*rlwm*rov*drvw/xvisv+
     &                 prf*drlwm3*rov*xrv/xvisv
                  divm(mi)=dprf4*rov*xrv/xvisv
               endif
               dgvp(mi)=drovp
               dgve(mi)=drovt
               envf(mi)=env
               devf(mi)=dhvp
               devef(mi)=dhvt
               rolf(mi)=rol
               rovf(mi)=rov

               if(qdis.gt.0.0) then

c     organize source terms and derivatives
                  if(abs(ieosd).eq.2) then
                     hprod=sig*env+(1.0-sig)*enl
                     dhprdp=dsigp*env+sig*dhvp-dsigp*enl+(1.0-sig)*dhlp
                     dhprde=dsige*(env-enl)
                     dhprdw=dsigw*(env-enl)
                  endif
                  if(ieosd.eq.1) then
                     hprod=enl
                     dhprdp=dhlp
                     dhprde=dhlt
                  endif
                  if(abs(ieosd).eq.3) then
                     hprod=env
                     dhprdp=dhvp
                     dhprde=dhvt
                  endif
                  qh(mi)=hprod*qdis
                  dqh(mi)=dhprdp*qdis+hprod*dq(mi)
                  deqh(mi)=dhprde*qdis+hprod*dqt(mi)
                  deqw(mi)=dhprdw*qdis+hprod*dq3(mi)
               endif
               if(qdis.lt.0.) then
                  qh(mi)=qdis*eflow(mi)
                  dqh(mi)=dq(mi)*eflow(mi)
               endif
            endif
c
c     add intercomponent heat flux
c     this term transfers heat from water to methane (and back)
c     also note this term only contains derivative wrt water
c     derivative with respect to methane can also be derived
c
            if(qhflxmeth(mi).ne.0.0) then
               htc = qhflxmeth(mi)
               hflux=htc*(t(mi)-tmeth(mi))
               if(abs(ieosd).ne.2) then
                  dhflxp=0.0
                  dhflxe=htc
               else
                  dhflxp=htc*dtpa(mi)
                  dhflxe=0.0
               endif
c     this next if block contains derivative wrt methane component
               if(abs(ices(mi)).ne.2) then
                  dhflxew=-htc
               else
                  dhflxpm=-htc*dtpameth(mi)
                  dhflxem=0.0
               endif
               qh(mi) = qh(mi) + hflux
               dqh(mi) = dqh(mi) + dhflxp
               deqh(mi) = deqh(mi) + dhflxe
               deqpm(mi) = deqpm(mi) + dhflxpm
               deqm(mi) = deqm(mi) + dhflxem
            endif
c
c     add heat source term
c
            if(qflux(mi).ne.0.0) then
               if(qflxm(mi).gt.0.0) then
                  htc=qflxm(mi)
                  tbound=qflux(mi)
                  hflux=htc*(tl-tbound)
                  if(abs(ieosd).ne.2) then
                     dhflxp=0.0
                     dhflxe=htc
                  else
                     dhflxp=htc*dtps
                     dhflxe=0.0
                  endif
                  qh(mi)=qh(mi)+hflux
                  dqh(mi)=dqh(mi)+dhflxp
                  deqh(mi)=deqh(mi)+dhflxe
               else if(qflxm(mi).lt.0.0) then
                  htc=abs(qflxm(mi))
                  sbound=qflux(mi)
                  hflux=htc*(tl-sbound)
                  if(abs(ieosd).ne.2) then
                     dhflxp=0.0
                     dhflxe=0.0
                  else
                     dhflxp=0.0
                     dhflxe=htc
                  endif
                  qh(mi)=qh(mi)+hflux
                  dqh(mi)=dqh(mi)+dhflxp
                  deqh(mi)=deqh(mi)+dhflxe
               else
                  qh(mi)=qh(mi)+qflux(mi)
               endif
            endif
            if(ps(mi).eq.0.0) then

c     heat conduction only
               cprd=cpr(mi)
               if(kq.lt.0) then
                  eskd=eflow(mi)
                  edif=cprd*tl-eskd
                  permsd=wellim(mi)
                  qh(mi)=permsd*edif
                  deqh(mi)=permsd*cprd
               endif
               if(kq.ge.0.and.qflux(mi).eq.0.0) deqh(mi)=0.
               dtpae(mi)=1.
               denrd=denr(mi)*cprd
               sto1(mi)=0.0
               sto1(mi+neq)=denrd*tl
               deef(mi)=denrd*dtin
            endif
         enddo

         do     mid=1,neq
            mi=mid+ndummy
            deni(mi)=(sto1(mi)  -denh(mi))*dtin
            denei(mi)=(sto1(mi+neq)-deneh(mi))*dtin
         enddo

c     ****************************************************************
      else if(iflg.eq.2) then
c
c     calculations for fluid methane
c
c     note: heat capacity of rock thermal term removed
c     now included only with water conservation of energy equation
c
         drvw = 0.0
         drlw = 0.0
         drlm = 0.0
         drvm = 0.0
         iieosl=0
         do mid=1,neq
            mi=mid+ndummy
c     phase information now contained in array ices
            ieosd=ices(mi)

            pl=phimeth(mi)
            sl=smeth(mi)
c     water and methane are independent
            frac_hyd  = frachyd(mi)
            frac_w = fracw(mi)
            frac_g = 1.0-fracw(mi)-frachyd(mi)
            dfrac_w = 1.0d00
            dfrac_gw = -1.0d00
            dfrac_gm = -1.0d00

c
            if(ieosd.eq.2) then

c     two phase (gas/liquid) conditions
c     calculate relative permeabilities of vapor-liquid

               call methane_properties(6,1,dum1,dum2,sl,dum3,
     &              pcp(mi),dum4,dpcef(mi),dum5,dum6)

c     calculate relative permeabilities of vapor-liquid

               call methane_properties(7,1,dum1,dum2,sl,dum3,
     &              rvf(mi),drvpf(mi),drvef(mi),dum5,dum6)
               xrv=rvf(mi)
               drv=drvef(mi)
               drvp=drvpf(mi)

               call methane_properties(7,2,dum1,dum2,sl,dum3,
     &              rlf(mi),drlpf(mi),drlef(mi),dum5,dum6)
               xrl=rlf(mi)
               drl=drlef(mi)
               drlp=drlpf(mi)
            endif

            if(ieosd.eq.-2) then

c     two phase (liquid/solid) conditions
c     calculate relative permeabilities of vapor-liquid
c     rvf now containes the solid relative permeability

               call methane_properties(6,2,dum1,dum2,sl,dum3,
     &              pcp(mi),dum4,dpcef(mi),dum5,dum6)

c     calculate relative permeabilities of vapor-liquid

               call methane_properties(8,1,dum1,dum2,sl,dum3,
     &              rvf(mi),drvpf(mi),drvef(mi),dum5,dum6)
               xrv=rvf(mi)
               drv=drvef(mi)
               drvp=drvpf(mi)

               call methane_properties(8,2,dum1,dum2,sl,dum3,
     &              rlf(mi),drlpf(mi),drlef(mi),dum5,dum6)
               xrl=rlf(mi)
               drl=drlef(mi)
               drlp=drlpf(mi)
            endif

            if(ieosd.eq.2) then

c     two phase (gas/liquid) conditions

c     calculate phase-change temperature and dt/dp
               call methane_properties(4,2,pl,dum1,dum2,dum3,
     &              tl,dtps,dum4,dum5,dum6)
c     calculate phase-change pressure and dp/dt
               call methane_properties(5,2,tl,dum1,dum2,dum3,
     &              psatd,dum4,dpsatt,dum5,dum6)
c
            else if(ieosd.eq.-2) then

c     two phase (liquid/solid) conditions

c     calculate temperature and dt/dp
               call methane_properties(4,1,pl,dum1,dum2,dum3,
     &              tl,dtps,dum4,dum5,dum6)
c     calculate pressure  and dp/dt
               call methane_properties(5,1,tl,dum1,dum2,dum3,
     &              psatd,dum4,dpsatt,dum5,dum6)
            else
               tl=tmeth(mi)
            endif
            if(abs(ieosd).ne.3) then

c     liquid enthalpy and derivatives

               call methane_properties(1,2,pl,tl,dum2,dum3,
     &              enl,dhlp,dhlt,dum5,dum6)

c     liquid density and derivatives

               call methane_properties(2,2,pl,tl,dum2,dum3,
     &              rol,drolp,drolt,dum5,dum6)

c     modify density(explicit update) if it changes with concentration
               if(cden) then
c     Add correction for liquid species
                  cden_cor = cden_correction(mi)
                  rol = rol + cden_cor
               end if

c     liquid viscosity and derivatives

               call methane_properties(3,2,pl,tl,dum2,dum3,
     &              xvisl,dvislp,dvislt,dum5,dum6)

            endif

            if(ieosd.ge.2) then

c     vapor enthalpy and derivatives

               call methane_properties(1,3,pl,tl,dum2,dum3,
     &              env,dhvp,dhvt,dum5,dum6)

c     vapor density and derivatives

               call methane_properties(2,3,pl,tl,dum2,dum3,
     &              rov,drovp,drovt,dum5,dum6)

c     vapor viscosity and derivatives

               call methane_properties(3,3,pl,tl,dum2,dum3,
     &              xvisv,dvisvp,dvisvt,dum5,dum6)

            endif
            if(ieosd.le.-2) then

c     properties of solid phase
c     properties of solid phase will be put into variables for vapor
c     it is assumed that solid and vapor can not exist simultaneously at the same node

c     calculate solid enthalpy and derivative wrt p and t

               call methane_properties(1,1,pl,tl,dum2,dum3,
     &              env,dhvp,dhvt,dum5,dum6)

c     calculate solid density and derivative wrt p and t

               call methane_properties(2,1,pl,tl,dum2,dum3,
     &              rov,drovp,drovt,dum5,dum6)

c     calculate solid viscosity (should be very large!) and derivative wrt p and t

               call methane_properties(3,1,pl,tl,dum2,dum3,
     &              xvisv,dvisvp,dvisvt,dum5,dum6)

            endif

c     calculate special relative permeability for liquid water-methane gas

c     gaz 12-24-03
c     call methane_properties(11,1,pl,tl,frac_w,frac_hyd,
c     &                              rgwm,drgwmp,drgwmt,drgwm3,drgwm4)
            rgwm = rl_meth(mi)
            drgwmp = 0.0
            drgwmt = 0.0
            drgwm3 = drl_meth3(mi)
            drgwm4 = drl_meth4(mi)

c     added liquid relative permeability rajesh 11/20/2003
            call h2o_properties(11,1,pl,tl,frac_w,dum2,
     &           rlwm,drlwmp,drlwmt,drlwm3,dum6)
c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(3,1,pl,tl,fracw(mi),frachyd(mi),
     &           skhyd(mi),dskhydp,dskhydt,dskhydw,dskhydm)

c
c     save rate and derivatives for enthalp calculation (passed through commeth)
c

            source_hyd_temp = skhyd(mi)
            ds1_tmp = dskhydp
            ds2_tmp = dskhydt
            ds3_tmp = dskhydw
            ds4_tmp = dskhydm

c     calculate solid gas heat generation term and derivative wrt p and t and frachyd
c     kinetic approach
c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(4,1,pl,tl,fracw(mi),frachyd(mi),
     &           qhhyd(mi),dqhhydp,dqhhydt,dqhhydw,dqhhydm)

c     form dissociation flow term

            skmhyd(mi) = -ratgas*skhyd(mi)

c     load gas generation term derivatives

	    dskhyd1(mi) = -ratgas*dskhydp
	    dskhyd2(mi) = -ratgas*dskhydt
	    dskhyd3(mi) = -ratgas*dskhydw
	    dskhyd4(mi) = -ratgas*dskhydm

c     modify derivatives for 2-phase (should now depend on p, not t)
            if(abs(ieosd).eq.2) then
               drolp=drolp+drolt*dtps
               drovp=drovp+drovt*dtps
               dhlp=dhlp+dhlt*dtps
               dhvp=dhvp+dhvt*dtps
               dvisvp=dvisvp+dvisvt*dtps
               dvislp=dvislp+dvislt*dtps
               drolt=0.0
               drovt=0.0
               dhlt=0.0
               dhvt=0.0
               dvisvt=0.0
               dvislt=0.0
               dtd=1.0
            endif

c
c     gaz need to carry dq from water calcs
c     dq(mi)=0.0
            qhmeth(mi)=0.0
            dqh(mi)=0.0
            deqh(mi)=0.0
            dqt(mi)=0.0
            kq=kameth(mi)
            if(kq.ne.1) then
               skmeth(mi) =0.0
               dskmethw1(mi)= 0.0
               dskmethw3(mi)= 0.0
               dskmethw4(mi)= 0.0
            else
               dskmethw1(mi)= 0.0
               dskmethw3(mi)= 0.0
               dskmethw4(mi)= 0.0
            endif

            por=ps(mi)
            dporpl=dporp(mi)
            dportl=dport(mi)

            vol=volume(mi)

c     gaz skmethw should be removed (plus derivatives)
c     enough storage already  (deleted 1-12-04 gaz)
c     skmethw(mi) =0.0
            if(sk(mi).gt.0.0.and.kq.eq.0) then
c     calculate production factor for liquid water-methane gas
               call h2o_properties(12,1,pl,tl,frac_w,frac_hyd,
     &              prodfac,dum3,dum4,
     &              dprodfac3,dprodfac4)
               skmeth(mi)=sk(mi)*prodfac
               dskmethw1(mi)=dq(mi)*prodfac
               dskmethw3(mi)=sk(mi)*dprodfac3+dq3(mi)*prodfac
               dskmethw4(mi)=sk(mi)*dprodfac4
               dq(mi)=0.0
            else if(kq.lt.0) then
c     form pressure dependent flow term
c     gaz 2-19-04 added gas relative perms
               qhmeth(mi)=0.
               skmeth(mi)=0.0
c     tenma 6-6-2005
c     note this forces the methane pressure to equal the water pressure at wells
c     ie pressure equilibrium
c
               pflowmeth(mi) = pflow(mi)
               wellmeth(mi) = wellim(mi)
               if(pflowmeth(mi).gt.0.0) then
                  pldif=pl-pflowmeth(mi)
                  dpldt=0.0
                  permsd=wellmeth(mi)
                  if(pldif.le.0.0d00.and.kq.eq.-2) permsd=0.
                  qdis=permsd*rgwm*(pldif)
                  skmeth(mi)=qdis
                  dskmethw1(mi) =permsd*rgwm
                  dskmethw3(mi) =permsd*drgwm3*pldif
                  dskmethw4(mi) =permsd*drgwm4*pldif
               else
c     this case for specified methane fraction
                  fracmb=-pflowmeth(mi)
                  pldif=frac_g-fracmb
                  permsd=wellmeth(mi)
                  if(pldif.le.0.0d00.and.kq.eq.-2) permsd=0.
                  qdis=permsd*(pldif)
                  skmeth(mi)=qdis
                  dq(mi) =0.0
                  dskmethw1(mi)=0.0
                  dskmethw3(mi)=permsd*dfrac_gw
                  dskmethw4(mi)=permsd*dfrac_gm
               endif
               if(qdis.le.0.) then
                  eskd=eflowmeth(mi)
                  qhmeth(mi)=eskd*qdis
                  skmeth(mi)=qdis
                  dqh(mi)=eskd*dq(mi)
               endif
            endif
c     identify flux term
            qdis=skmeth(mi)

c     two phase conditions
            if(abs(ieosd).eq.2) then
c     saturation and relative permeabilities
               sv=1.d0-sl
c     accumulation terms
c     note new terms for fraction of water
               den=por*(sl*rol+sv*rov)*frac_g
               eqdum=(sl*rol*enl+sv*rov*env-pl)*frac_g
c     dene=((1.-por)*cp*tl+por*eqdum)
               dene=por*eqdum
c     production of steam
c     note xrv and xrl now also depend on frac_g (and thus frac_g)
               rag=rol*xvisv/rov/xvisl
               sig=xrv/(xrv+rag*xrl)
c     derivatives of accumulation terms
               rop=por*(sv*drovp+sl*drolp)*frac_g
               damp =rop*dtin
c     daep =((1.d0-por)*cp*dtps+por*frac_g*(sv*drovp*env+
               daep =(por*frac_g*(sv*drovp*env+
     &              sv*rov*dhvp+sl*drolp*enl+sl*rol*dhlp)-por)*dtin
               damh =por*frac_g*(rol-rov)*dtin
               daeh =por*frac_g*(rol*enl-rov*env)*dtin
c     add derivative wrt methane fraction
               damm=por*(sl*rol+sv*rov)*dfrac_gm
               daem=por*(sl*rol*enl+sv*rov*env-pl)*dfrac_gm
c     add derivative wrt water fraction
               damw=por*(sl*rol+sv*rov)*dfrac_gw
               daew=por*(sl*rol*enl+sv*rov*env-pl)*dfrac_gw
c     derivatives of sink terms
               if(qdis.gt.0.0) then
                  dragp=(rov*xvisl*(drolp*xvisv+rol*dvisvp)-rol*
     2                 xvisv*(drovp
     3                 *xvisl+rov*dvislp))/(xvisl*rov)**2
                  if(sig.ne.0.d0.and.sig.ne.1.d0) then
                     dsigp=-xrv*dragp*xrl/(xrv+rag*xrl)**2
                     dsige=((xrv+rag*xrl)*drv-xrv*(drv+rag*drl))
     3                    /(xrv+rag*xrl)**2
                     dsigm=(-xrv*(drvm+rag*drlm))
     3                    /(xrv+rag*xrl)**2
                     dsigw=((xrv+rag*xrl)*drvw-xrv*(rag*drlw))
     3                    /(xrv+rag*xrl)**2
                  else
                     dsigp=0.d0
                     dsige=0.d0
                     dsigm=0.d0
                     dsigw=0.d0
                  end if
               end if
            end if

c     compressed liquid
            if(ieosd.eq.1) then
               xrl=1.0
               xrv=0.0
               drl=0.0
               drv=0.0
               dtps=0.0
               sl=1.d0
               sv=0.0
               sig=0.d0
               rov=0.d0
               env=0.d0
               drovp=0.0
               drovt=0.0
               dhvp=0.0
               dhvt=0.0
               dvisvp=0.0
               dvisvt=0.0
               dtd=1.0
               xvisv=1.d20

c     accumulation terms
               den=rol*por*frac_g
c     dene=(1.d0-por)*cp*tl+por*(rol*enl-pl)*frac_g
               dene=por*(rol*enl-pl)*frac_g
c     Date 11/25/03 RJP added to compensate for -ve frac_g remove later
c     dene=dene+2.
c     derivatives of accumulation terms
               damp=(rol*dporpl+por*drolp)*dtin*frac_g
               damm=rol*por*dtin*dfrac_gm
               damw=rol*por*dtin*dfrac_gw
               daep1=(dporpl*rol*enl+por*drolp*enl+por*rol*dhlp
     &              -dporpl*pl-por)*frac_g
c     daep2=-dporpl*cp*tl
               daep2=0.0d00
               daep=(daep1+daep2)*dtin
               damh=(dportl*rol+por*drolt)*dtin*frac_g
c     daeh=(-dportl*cp*tl+(1.-por)*cp+(dportl*(enl*rol-pl)+
               daeh=((dportl*(enl*rol-pl)+
     &              por*(rol*dhlt+enl*drolt))*frac_g)*dtin
               daem=por*(rol*enl-pl)*dtin*dfrac_gm
               daew=por*(rol*enl-pl)*dtin*dfrac_gw

            end if

c     superheated vapour
            if(abs(ieosd).eq.3) then
               dtps=0.0
               xrl=0.0
               xrv=1.0
               drl=0.0
               drv=0.0
               sl=0.d0
               sv=1.d0
               sig=1.d0
               rol=0.d0
               enl=0.d0
               drolp=0.0
               drolt=0.0
               dhlp=0.0
               dhlt=0.0
               dvislp=0.0
               dvislt=0.0
               dtd=1.0
               xvisl=1.d20

c     accumulation terms
               den=rov*por*frac_g
c     dene=(1.d0-por)*cp*tl+por*(rov*env-pl)*frac_g
               dene=por*(rov*env-pl)*frac_g

c     derivatives of accumulation terms
               damp=(dporpl*rov+por*drovp)*dtin*frac_g
               damm=rov*por*dtin*dfrac_gm
               damw=rov*por*dtin*dfrac_gw
               daep1=(dporpl*rov*env+por*drovp*env+por*rov*dhvp
     &              -dporpl*pl-por)*frac_g
c     daep2=-dporpl*cp*tl
               daep2=0.0d00
               daep=(daep1+daep2)*dtin
               damh=(dportl*rov+por*drovt)*dtin*frac_g
c     daeh=(-dportl*cp*tl+(1.-por)*cp+(dportl*(env*rov-pl)+
               daeh=((dportl*(env*rov-pl)+
     &              por*(rov*dhvt+env*drovt))*frac_g)*dtin
               daem=por*(rov*env-pl)*dtin*dfrac_gm
               daew=por*(rov*env-pl)*dtin*dfrac_gw

            end if
            if(ps(mi).ne.0.0) then

c     store derivatives of accumulation terms
               dmef(mi)=damh
               dmpf(mi)=damp
               dmmf(mi)=damm
               dmwf(mi)=damw
               depf(mi)=daep
               deef(mi)=daeh
               demf(mi)=daem
               dewf(mi)=daew
               dtpameth(mi)=dtps
               dtpaemeth(mi)=dtd
               tmeth(mi)=tl
               smeth(mi)=sl

c     save accumulation terms for possible volume changes
               sto1(mi)=den
               sto1(mi+neq)=dene
               dstm(mi)=por*rov*sv*vol
               dil(mi)=0.0
               dilp(mi)=0.0
               dile(mi)=0.0
               dilm(mi)=0.0
               dilw(mi)=0.0
               div(mi)=0.0
               divp(mi)=0.0
               dive(mi)=0.0
               divm(mi)=0.0
               divw(mi)=0.0

c     permeability reduction factor

               prf = permhyd(mi)
               dprf4 = dpermhyd4(mi)

               if(abs(ieosd).ne.3) then

c     modify flow terms for new upwind scheme
c     note rgwm used for both phases of methane
                  dql=prf*rgwm*rol*xrl/xvisl
                  dil(mi)=dql
                  dilp(mi)=prf*rgwm*(drolp*xrl/xvisl-
     &                 rol*xrl/xvisl**2*dvislp+rol*drlp/xvisl)
                  dile(mi)=prf*rgwm*(drolt*xrl/xvisl+rol*drl/xvisl
     &                 -rol*xrl/xvisl**2*dvislt)
                  dilw(mi)=prf*rgwm*rol*drlw/xvisl+
     &                 prf*drgwm3*rol*xrl/xvisl
                  dilm(mi)=dprf4*rgwm*rol*xrl/xvisl+
     &                 prf*drgwm4*rol*xrl/xvisl
               endif
               dglp(mi)=drolp
               dgle(mi)=drolt
               enlfmeth(mi)=enl
               delf(mi)=dhlp
               delef(mi)=dhlt

c     modify flow terms for new upwind scheme
               if(ieosd.ne.1) then
                  dqv=prf*rgwm*rov*xrv/xvisv
                  div(mi)=dqv
                  divp(mi)=prf*rgwm*(drovp*xrv/xvisv-
     &                 rov*xrv/xvisv**2*dvisvp+rov*drvp/xvisv)
                  dive(mi)=prf*rgwm*(drovt*xrv/xvisv+rov*drv/xvisv
     &                 -rov*xrv/xvisv**2*dvisvt)
                  divw(mi)=prf*rgwm*rov*drvw/xvisv+
     &                 prf*drgwm3*rov*xrv/xvisv
c     divm(mi)=dprf4*rov*xrv/xvisv
c     divw(mi)=prf*rgwm*rov*drvw/xvisv+prf*drgwm3*rov*xrv/xvisv
                  divm(mi)=dprf4*rgwm*rov*xrv/xvisv+
     &                 prf*drgwm4*rov*xrv/xvisv
               endif
               dgvp(mi)=drovp
               dgve(mi)=drovt
               envfmeth(mi)=env
               devf(mi)=dhvp
               devef(mi)=dhvt
               rolfmeth(mi)=rol
               rovfmeth(mi)=rov

               if(qdis.ge.0.0) then

c     organize source terms and derivatives
                  if(abs(ieosd).eq.2) then
                     hprod=sig*env+(1.0-sig)*enl
                     dhprdp=dsigp*env+sig*dhvp-dsigp*enl+(1.0-sig)*dhlp
                     dhprde=dsige*(env-enl)
                     dhprdm=dsigm*(env-enl)
                     dhprdw=dsigw*(env-enl)
                  endif
                  if(ieosd.eq.1) then
                     hprod=enl
                     dhprdp=dhlp
                     dhprde=dhlt
                     dhprdm=0.d0
                     dhprdw=0.d0
                  endif
                  if(abs(ieosd).eq.3) then
                     hprod=env
                     dhprdp=dhvp
                     dhprde=dhvt
                     dhprdm=0.d0
                     dhprdw=0.d0
                  endif
c     gaz 1-12-04 removed skmethw
                  qhmeth(mi)=hprod*(skmeth(mi))
                  dqmh(mi)=dhprdp*(skmeth(mi))
     &                 +hprod*dskmethw1(mi)
c     gaz 1-12-04 gaz
c     &                      +hprod*dq(mi)
                  deqmh(mi)=dhprde*(skmeth(mi))
                  deqw(mi)=dhprdw*(skmeth(mi))
     &                 +hprod*dskmethw3(mi)
                  deqm(mi)=dhprdm*(skmeth(mi))
     &                 +hprod*dskmethw4(mi)
               endif
               if(qdis.lt.0.) then
                  qhmeth(mi)=qdis*eflowmeth(mi)
                  dqmh(mi)=dskmethw1(mi)*eflowmeth(mi)
               endif
            endif
         enddo

         do     mid=1,neq
            mi=mid+ndummy
            denmethi(mi)=(sto1(mi)  -denmethh(mi))*dtin
            denemethi(mi)=(sto1(mi+neq)-denemethh(mi))*dtin
         enddo

c     ****************************************************************
      else if(iflg.eq.3) then
c
c     calculations for methane hydrate
c
         iieosl=0
         do mid=1,neq
            mi=mid+ndummy
c     phase information now contained in array ices
            ieosd=ices(mi)

            pl=phimeth(mi)
            tl=tmeth(mi)
c     water and methane are independent
c     gaz 2-25-2003
            frac_hyd  = frachyd(mi)
            dfrac_hyd = 1.0d00
            dfrac_w = -1.0d00
c     first zero out sources and derivatives
            qhhyd(mi)=0.0
            dq(mi)=0.0
            dqt(mi)=0.0
            dqh(mi)=0.0
            deqh(mi)=0.0
            deqpm(mi)=0.0
            deqm(mi)=0.0
            por = ps(mi)
            dporpl=dporp(mi)
            dportl=dport(mi)

c     properties of solid phase
c     it is assumed that solid and vapor can not exist simultaneously at the same node

c     calculate solid enthalpy and derivative wrt p and t

            call hydrate_properties(1,1,pl,tl,dum2,dum3,
     &           enl,dhlp,dhlt,dum5,dum6)

c     calculate solid density and derivative wrt p and t

            call hydrate_properties(2,1,pl,tl,dum2,dum3,
     &           rol,drolp,drolt,dum5,dum6)

c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(3,1,pl,tl,fracw(mi),frachyd(mi),
     &           skhyd(mi),dskhydp,dskhydt,dskhydw,dskhydm)
c
c     save rate and derivatives for enthalp calculation (passed through commeth)
c

            source_hyd_temp = skhyd(mi)
            ds1_tmp = dskhydp
            ds2_tmp = dskhydt
            ds3_tmp = dskhydw
            ds4_tmp = dskhydm
c
c     calculate solid gas heat generation term and derivative wrt p and t and frachyd
c     kinetic approach
c     porh is pass-through variable ps(mi) to hydrate_properties

            porh = ps(mi)
            volh = sx1(mi)

            call hydrate_properties(4,1,pl,tl,fracw(mi),frachyd(mi),
     &           qhhyd(mi),dqhhydp,dqhhydt,dqhhydw,dqhhydm)

c     form dissociation flow term
            skhyd(mi) = rathyd*skhyd(mi)
c     form heat dissociation flow term (minus means add heat to system)
            qhhyd(mi) = rathyd*qhhyd(mi)

c     load gas generation term derivatives

	    dskhyd1(mi) = rathyd*dskhydp
	    dskhyd2(mi) = rathyd*dskhydt
	    dskhyd3(mi) = rathyd*dskhydw
	    dskhyd4(mi) = rathyd*dskhydm
	    dqhhyd1(mi) = rathyd*dqhhydp
	    dqhhyd2(mi) = rathyd*dqhhydt
	    dqhhyd3(mi) = rathyd*dqhhydw
	    dqhhyd4(mi) = rathyd*dqhhydm

c     compressed liquid
            xvisl=1.d20
            xvisv=1.d20

c     accumulation terms
            den=rol*por*frac_hyd
            dene=por*(rol*enl-pl)*frac_hyd
            sto1(mi)=den
            sto1(mi+neq)=dene

c     derivatives of accumulation terms
            damp=(rol*dporpl+por*drolp)*dtin*frac_hyd
            damm=rol*por*dtin*dfrac_hyd
c     damw=rol*por*dtin*dfrac_w
            damw=0.0
            daep1=(dporpl*rol*enl+por*drolp*enl+por*rol*dhlp
     &           -dporpl*pl-por)*frac_hyd
c     daep2=-dporpl*cp*tl
            daep2=0.0d00
            daep=(daep1+daep2)*dtin
            damh=(dportl*rol+por*drolt)*dtin*frac_hyd
c     daeh=(-dportl*cp*tl+(1.-por)*cp+(dportl*(enl*rol-pl)+
            daeh=((dportl*(enl*rol-pl)+
     &           por*(rol*dhlt+enl*drolt))*frac_hyd)*dtin
            daem=por*(rol*enl-pl)*dtin*dfrac_hyd
c     daew=por*(rol*enl-pl)*dtin*dfrac_w
            daew=0.0
            if(ps(mi).ne.0.0) then

c     store derivatives of accumulation terms
               dmef(mi)=damh
               dmpf(mi)=damp
               dmmf(mi)=damm
               dmwf(mi)=damw
               depf(mi)=daep
               deef(mi)=daeh
               demf(mi)=daem
               dewf(mi)=daew
               dtpameth(mi)=dtpa(mi)
               dtpaemeth(mi)=dtpae(mi)
               tmeth(mi)=tl
               smeth(mi)=s(mi)

            endif
         enddo

         do     mid=1,neq
            mi=mid+ndummy
            denhydi(mi)=(sto1(mi)  -denhydh(mi))*dtin
            denehydi(mi)=(sto1(mi+neq)-denehydh(mi))*dtin
         enddo

c     end if block on different fluids
      endif

      deallocate(sto1)

      return
      end