! $Header: m:/default/source/RCS/ngitm.f,v 1.142 2013/10/21 21:27:38 JBE Exp $

!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  NEW INTERSTATE TRANSMISSION MODULE (ITM) FOR THE NGTDM
!
!  01/02/97       SPLIT FROM PREPROCESSING PORTION, PUT INTO NGTDM
!
!  STATUS:
!
!  CALLED BY:     NGMAIN
!
!  CALLS:         NGITM_PRE            ! PREPROCESSOR
!                 NGSET_NODEDMD        ! SET NET DMDS
!                 NGDOWN_TREE(NET)     ! DEFINE NODE DMDS & FLOWS
!                 NGSET_SUPPR          ! SET SUPPLY PR USING CURVE
!                 NGSET_ARCFEE         ! SET FIX/VAR TAR ALONG ARCS
!                 NGSET_STORPR         ! SET STORAGE PRICE
!                 NGUP_TREE(NET)       ! SET NODE PRICE
!                 NGSET_SECPR          ! SET END-USE SECTOR PRICES
!                 NGCHK_CONVNG         ! CHECK CONVERGENCE UP/DOWN TREE
!                 NGSET_PREV           ! SET PREV SUP/DMD FOR CONV CHK NXT CYC
!                 NGITM_BASPR          ! SET BASPR FOR PO IN DMD CURVE EQ
!                 NGSET_ACTPCAP        ! SET ACTUAL/FINAL CAPACITIES ON ARCS
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
      SUBROUTINE NGTDM_ITM
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'
      include 'nghistinc'
      include 'ngptmitm'

      INTEGER*4  NET          ! REPRESENTS PK,OP NETWORK
      INTEGER*4  DEST,N       ! REGION ID
      INTEGER*4  A            ! ARC ID

      INTEGER*4  ARC_1,ARC_2  ! INPUT ARC COUNTERS
      INTEGER*4  SRC          ! NODE ID
      INTEGER*4  L,STID       ! COUNTER
! --------------

!!!   TEMP: SET PIPELINE UTILIZATIONS TO 1 AFTER HIST YEARS
      IF (MODYR .GT. NOBLDYR) THEN   !utz
       DO A=1,NARCS               !utz
        SRC = ARC_2NODE(A,1)      !utz
                                  !utz
        IF (SRC .LE. TNODES) THEN !utz
          PKUTZ(A) = 1.0          !utz
          OPUTZ(A) = 1.0          !utz
        ENDIF                     !utz
       ENDDO                      !utz
      ENDIF                       !utz

      CALL NGITM_PRE              ! PREPROCESSING FOR THE ITM
                                  ! - SET CONST DMD
                                  ! - SET MAX CAPACITY

!     IF (CURITR.EQ.1 .AND. MODYR.GE.2011 .AND. MODYR.LE.2018) THEN
!       PARM_SUPELAS(1) = PARM_SUPELAS(1) + 0.0375
!       PARM_SUPELAS(2) = PARM_SUPELAS(2) + 0.03125
!       PARM_SUPELAS(3) = PARM_SUPELAS(3) + 0.025    
!       PARM_SUPELAS(4) = PARM_SUPELAS(4) + 0.01875
!       PARM_SUPELAS(5) = PARM_SUPELAS(5) + 0.0         
!     ENDIF
! SET ARC_SHRPR TO T-1 LEVEL EACH NEMS ITERATION
      DO NET=1,NETWORK
        DO A=1,NARCS
          ARC_SHRPR(NET,A) = ARC_PREV_SHRPR(NET,A)
        ENDDO
      ENDDO

! SET RBKSTOP_PADJ TO 0.0 1ST NEMS ITR
      DO NET=1,NETWORK
        DO DEST=1,TNODES
          RBKSTOP_FLG(NET,DEST) = -1
          BKSTOP_PADJ(NET,DEST)  = 0.1
!EM4      IF (CURITR .EQ. 1) THEN
            RBKSTOP_PADJ(NET,DEST) = 0.0
!CCC        RBKSTOP_PADJ(NET,DEST) = 0.5 * RBKSTOP_PADJ(NET,DEST)
!EM4      ENDIF
        ENDDO
      ENDDO

! CYCLE UP & DOWN NETWORK TREE

      CYCLE = 1                       ! BEGIN CYCLE AT 1
      CNVGFLG = 0
      DO WHILE ((CNVGFLG .EQ. 0) .AND. (CYCLE .LE. MAXCYCLE))

        CALL NGSET_NODEDMD            ! SPLIT F/I INTO P/O; ADD CONST DMD

        IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN
          IF ((CYCLE .EQ. 1) .AND. (CURITR .EQ. 1)) THEN
            CALL NGHIST_DISCR
          ENDIF

! ADD HISTORICAL NET INJECTIONS TO NODE_DMD ON OP NETWORK
          DO L=1,NPROC
            DEST = PROC_ORD(L)

            ARC_1 = ARC_LOOP(PKNET,DEST,1)
            ARC_2 = ARC_LOOP(PKNET,DEST,2)
                          ! ADD NET INJECTIONS TO OFFPEAK DMDS
            DO A=ARC_1,ARC_2
              SRC = ARC_2NODE(A,1)
              IF (SRC .GT. (TNODES+SNODES)) THEN
                STID = SRC - (TNODES+SNODES)
                NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + &
                 HNETINJ(STID,MODYR) - HNETWTH(STID,MODYR)
              ENDIF
            ENDDO
          ENDDO
        ENDIF

        DO NET=1,NETWORK
          CALL NGDOWN_TREE(NET)       ! DEFINE NODE DMDS & FLOWS
        ENDDO

!       IF (MODYR .LE. LHISYR) THEN
!         CALL HNGSET_SUPPR           ! SET HIST SUPPLY, FLOWS BY SEASON
!        else
!         CALL NGCHK_CONVNG           ! CHECK UP/DOWN TREE CONV USING SUP PROD
!       endif

        CALL NGCHK_CONVNG             ! CHECK UP/DOWN TREE CONV USING SUP PROD
                                      ! AND SET SUPPLY PR USING CURVE
        IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN
          IF (CNVGFLG .EQ. 1) THEN
            CALL HNGSET_SUPPR         ! SET HIST SUPPLY, FLOWS BY SEASON
          ENDIF
        ENDIF

        CALL NGSET_ARCFEE             ! SET FIX/VAR TAR ALONG ARCS

        DO NET=NETWORK,1,-1           ! SET NODE & STORAGE PR
          IF (NET .EQ. PKNET) CALL NGSET_STORPR
          CALL NGUP_TREE(NET)
        ENDDO

        CALL NGSET_INTRAFLO           ! SET INTRAREGIONAL FLOWS & CAPACITIES
                                      ! (AND FOR LHISYR,
                                      ! SET CITYGATE PRICES AND BENCHMARK FAC)

        CALL NGSET_SECPR              ! SET END-USE SECTOR PRICES

        CALL NGSET_PREV               ! SET PREV SUP/DMD FOR CONV CHK NXT CYC

                                      ! DEBUG REPORTS
        IF (NGDBGITR(4,2)) THEN
          CALL NGITM_DEBUG2(NGOTREE)
          CALL NGITM_DEBUG3(NGOTREE)
        ENDIF

        IF (NGDBGITR(4,1)) THEN
          CALL NGITM_DEBUG7(NGOBAL)
        ENDIF

        CYCLE = CYCLE+1
      ENDDO

      IF (CNVGFLG .EQ. 0) THEN
        WRITE(NGOERR,*) 'NOT CONVERGED ON CYCLE= ',MAXCYCLE, &
          '  ITR= ',CURITR,'  YEAR= ',MODYR, '     ! ATTN4'
      ENDIF

      CALL NGITM_BASPR                ! SET BASPR FOR PO IN DMD CURVE EQ
      CALL NGSET_ACTPCAP              ! SET ACTUAL/FINAL CAPACITIES ON ARCS

      IF (NGDBGITR(4,11)) THEN
        CALL NGITM_DEBUG7(NGOBAL)
      ENDIF

      IF (NGDBGITR(4,12)) THEN
        CALL NGITM_DEBUG2(NGOTREE)
        CALL NGITM_DEBUG3(NGOTREE)
      ENDIF

      CALL NGDBUG_DTM03(1)

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET NET NODE DEMANDS USING END-USE AND CONST DEMANDS
!     NODE_DMD
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_NODEDMD
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'nghistinc'
      include 'ogglobal'

      INTEGER*4  A,J,L,I       ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  ST            ! STORAGE NODE ID (1-14)
      INTEGER*4  NET           ! REPRESENTS PK, OP NETWORK
      INTEGER*4  N             ! NODE ID
      INTEGER*4  SEC           ! SECTOR ID (1-5)

      REAL*4     PKQTY_F       ! PLACEHOLDER FOR PF QTY
      REAL*4     OPQTY_F       ! PLACEHOLDER FOR OF QTY
      REAL*4     PKQTY_I       ! PLACEHOLDER FOR PI QTY
      REAL*4     OPQTY_I       ! PLACEHOLDER FOR OI QTY
      REAL*4 ADJ               ! VOLUME TO ADJUST NEW ENGLAND IMPORTS IF NET DEMAND FALLS TOO LOW
      REAL*4 MINDMD            ! MINIMUM NET NODE DEMAND IN NEW ENGLAND

      INTEGER*4 V, W, C
      LOGICAL   TMPSET/.TRUE./
! -------------

      IF (TMPSET) THEN
        IF (MODYR .GT. LHISYR) THEN
          TMPSET = .FALSE.
        ENDIF

        PERMTH(PKNET) = 1./4.
        PERMTH(OPNET) = 1./8.
        DO C=1,NETWORK
          DO W=1,TNODES
            SPERMTH(C,W) = 0.30
            IF (C.EQ.1) THEN
              SPERMTH(C,W) = HSPERJAN(W,LHISYR+1)
            ENDIF
          ENDDO
          DO W=1,SNODES
           IF(SUPARRAY(W).EQ.1) THEN
            PPERMTH(C,W) = PERMTH(C)
            IF (C.EQ.1 .AND. SUPTYPE(W).LE.2) THEN
              PPERMTH(C,W) = HPPERJAN(W,LHISYR+1)
            ENDIF
            IF(W.GE.FSRGN(1).AND.W.LT.FSRGN(3)) PPERMTH(C,W+FSRGN(7)-1)=PPERMTH(C,W)     !AD GAS
           ENDIF
          ENDDO
          DO W=1,NNGEM-1
            UCPERMTH(C,W) = PERMTH(C)
            IF (C.EQ.1) THEN
              UCPERMTH(C,W) = HUCPERJAN(W,LHISYR+1)
            ENDIF
!xxx        UCPERMTH(C,W) = .30
          ENDDO
          DO W=1,DNODES

!xxx        NCPERMTH(C,W,1) = .40
            NCPERMTH(C,W,1) = .30
            NCPERMTH(C,W,2) = .28
            NCPERMTH(C,W,3) = .26
            NCPERMTH(C,W,4) = PERMTH(C)
!xxx        NCPERMTH(C,W,1) = PERMTH(C)
!xxx        NCPERMTH(C,W,2) = PERMTH(C)
!xxx        NCPERMTH(C,W,3) = PERMTH(C)
!xxx        NCPERMTH(C,W,4) = PERMTH(C)
            IF (C.EQ.1) THEN
              DO V=1,DSEC-1
                NCPERMTH(C,W,V) = HCPERJAN(W,V,LHISYR+1)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
      ENDIF

! RESET NODE DEMANDS: CONST DMDS/SUP

      DO NET=1,NETWORK
        DO N=1,TNODES+SNODES+STNODES
          NODE_DMD(NET,N) = 0.0
        ENDDO

        DO N=1,TNODES
!       write(69,*) cycle,'cdmd',modyr,n,net,NODE_CDMD(NET,N)
          NODE_DMD(NET,N) = NODE_CDMD(NET,N)
                                     ! peak month
          MTH_CONS(NET,N) = MTH_CDMD(NET,N)
        ENDDO
      ENDDO

      IF (((CYCLE .EQ. 1) .OR. (CYCLE.EQ.0)) .AND. &
         (CURITR .EQ. 1)) THEN
!       WRITE (NGODTM,*) " YR  IT CY RG      PEAK   OFFPEAK",
!    *   "   <--NODE_CDMD"
!       DO N=1,TNODES
!         WRITE (NGODTM,110) MODYR,CURITR,CYCLE,N,
!    *     (NODE_CDMD(NET,N),NET=1,NETWORK)
!       ENDDO
        WRITE (NGODTM,*) " YR  IT CY RG      RES       COM", &
         "       IND       TRN   <--ZNGQTY_F"
        DO N=1,DNODES
          WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, &
           (ZNGQTY_F(SEC,N),SEC=1,DSEC-1)
        ENDDO
        WRITE (NGODTM,*) " YR  IT CY RG      RES       COM", &
         "       IND       TRN   <--ZNGQTY_I"
        DO N=1,DNODES
          WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, &
           (ZNGQTY_I(SEC,N),SEC=1,DSEC-1)
        ENDDO
        WRITE (NGODTM,*) " YR  IT CY RG   U_FIRM    U_INTR", &
         "                       <--ZNGUQTY_*"
        DO J=1,NNGEM-1
          WRITE (NGODTM,111) MODYR,CURITR,CYCLE,J, &
           ZNGUQTY_F(J),ZNGUQTY_I(J)
        ENDDO
      ENDIF
 110  FORMAT(1X,I4,I3,I3,I3,2(F10.3))
 111  FORMAT(1X,I4,I3,I3,I3,4(F10.3))

! RESET NODE DEMANDS: NEW END-USE DMDS

                           ! NON-UTILITY
      DO N=1,DNODES
        DO SEC=1,DSEC-1
          PKQTY_F = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N)
          OPQTY_F = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_F(SEC,N)
          PKQTY_I = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N)
          OPQTY_I = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_I(SEC,N)
          NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + &
             PKQTY_F + PKQTY_I
          NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + &
             OPQTY_F + OPQTY_I
          NGQTY_SF(PKNET,SEC,N) = PKQTY_F
          NGQTY_SF(OPNET,SEC,N) = OPQTY_F
          NGQTY_SI(PKNET,SEC,N) = PKQTY_I
          NGQTY_SI(OPNET,SEC,N) = OPQTY_I
                                     ! peak month
          MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + &
             ((PKQTY_F + PKQTY_I) * NCPERMTH(PKNET,N,SEC))
          MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + &
             ((OPQTY_F + OPQTY_I) * NCPERMTH(OPNET,N,SEC))
        ENDDO
      ENDDO
      
                           ! UTILITY
      DO J=1,NNGEM-1
        N = EMMSUB_NG(J)
        PKQTY_F = PKSHR_UDMD_F(J) * ZNGUQTY_F(J)
        OPQTY_F = (1.-PKSHR_UDMD_F(J)) * ZNGUQTY_F(J)
        PKQTY_I = PKSHR_UDMD_I(J) * ZNGUQTY_I(J)
        OPQTY_I = (1.-PKSHR_UDMD_I(J)) * ZNGUQTY_I(J)
        NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + &
           PKQTY_F + PKQTY_I
        NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + &
           OPQTY_F + OPQTY_I
        NGUQTY_SF(PKNET,J) = PKQTY_F
        NGUQTY_SF(OPNET,J) = OPQTY_F
        NGUQTY_SI(PKNET,J) = PKQTY_I
        NGUQTY_SI(OPNET,J) = OPQTY_I
                                     ! peak month
        MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + &
           ((PKQTY_F + PKQTY_I) * UCPERMTH(PKNET,J))
        MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + &
           ((OPQTY_F + OPQTY_I) * UCPERMTH(OPNET,J))
      ENDDO
      
! RESET NODE DEMANDS: NEW END-USE DMDS

!     DO N=1,DNODES
!       DO SEC=1,DSEC-1
!         NGQTY_SF(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N)
!         NGQTY_SF(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) *
!    *                            ZNGQTY_F(SEC,N)
!         NGQTY_SI(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N)
!         NGQTY_SI(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) *
!    *                            ZNGQTY_I(SEC,N)
!         NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) +
!    *       NGQTY_SF(PKNET,SEC,N) + NGQTY_SI(PKNET,SEC,N)
!         NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) +
!    *       NGQTY_SF(OPNET,SEC,N) + NGQTY_SI(OPNET,SEC,N)
!       ENDDO
!     ENDDO

! NOTE: THE FOLLOWING IS DONE BECAUSE NGUQTY_SF AND _SI ARE NEEDED
!       IN SUBROUTINE NGSET_SECPR TO DETERMINE END-USE UTILITY PR

!     DO J=1,NNGEM-1          ! UTILITY SUBREGIONS 1-16
!       NGUQTY_SF(PKNET,J) = PKSHR_UDMD_F(J) * NGUQTY_F(J)
!       NGUQTY_SF(OPNET,J) = (1.-PKSHR_UDMD_F(J)) *
!    *                          NGUQTY_F(J)
!       NGUQTY_SI(PKNET,J) = PKSHR_UDMD_I(J) * NGUQTY_I(J)
!       NGUQTY_SI(OPNET,J) = (1.-PKSHR_UDMD_I(J)) *
!    *                          NGUQTY_I(J)
!     ENDDO


      IF (CYCLE.EQ.1 .AND. FIXLNGFLG) THEN                     !YD1LNG: DO ADJ ONLY WHEN FIXED LNG
        I = 1                 ! FOR NEW ENGLAND, CHECK IF NODE_DMD TOO LOW
        N = MAPLNG_NG(I)
        ADJ = 0.0
        MINDMD = 50.0
        IF (NODE_DMD(PKNET,N).LT.MINDMD) ADJ = ADJ + (MINDMD - NODE_DMD(PKNET,N)) / PKSHR_ILNG(I)
        IF (NODE_DMD(OPNET,N).LT.MINDMD) ADJ = ADJ + (MINDMD - NODE_DMD(OPNET,N)) / (1.-PKSHR_ILNG(I))
        IF (ADJ.GT.oOGQNGIMP(14+I,CURIYR)) ADJ = oOGQNGIMP(14+I,CURIYR)
        NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + (ADJ * PKSHR_ILNG(I))
        NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + (ADJ * (1.-PKSHR_ILNG(I)))
        oOGQNGIMP(14+I,CURIYR) = oOGQNGIMP(14+I,CURIYR) - ADJ
 
        FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) - PKSHR_ILNG(I) * ADJ
        FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) - (1.-PKSHR_ILNG(I)) * ADJ

        MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (PKSHR_ILNG(I) * ADJ * 0.25)    !1/4
        MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + ((1.-PKSHR_ILNG(I))*ADJ* 0.125) !1/8

      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  MOVE DOWN TREE,
!  DETERMINE SUPPLY SHARES AND FLOWS,
!  ACCUMULATE DEMANDS AT SOURCE NODES
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  CALLS TO:   NGSHR_CALC
!              NGSHR_MAXCHK
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGDOWN_TREE(NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngsteoinc'
      include 'nghistinc'
      include 'ngcdmdinc'
 
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  L,N,A         ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  PFUEL_FLG(ARCS) ! FLAG INDICATING PIPE FUEL CONSUMP

      REAL*4     TFLOW         ! TOTAL FLOW ALONG PIPE ARCS INTO A NODE
      REAL*4     NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC
      REAL*4     GAMMATMP      ! TMP PLACEHOLDER FOR GAMMAFAC FOR OPT 5

      LOGICAL    ONCE/.TRUE./  ! DO ONLY ONCE
! -------------

      IF (ONCE) THEN
        ONCE = .FALSE.
        GAMMATMP = GAMMAFAC     ! temp
      ENDIF

! INITIALIZE BKSTOP TO ZERO BEFORE ALLOCATING SHARES

      DO N=1,TNODES
        BKSTOP(NET,N) = 0.0
      ENDDO
!CCC  BKSTOP_FLG = 0

! LOOP OVER PROCESSING NODES GOING DOWN NETWORK

      DO L=1,NPROC             ! NUMBER OF PROCESSING NODES
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(NET,DEST,1)
        ARC_2 = ARC_LOOP(NET,DEST,2)

! DEFINE PIPE FUEL CONSUMPTION AND ADD TO NET DMD (NODE_DMD)
!    PFUEL_FAC = PF / NODE_DMD(W/O PF)

        IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN
          IF ((NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)).NE.0.0) &
            HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / &
                                       (NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST))
        ELSE 
          IF (NODE_DMD(NET,DEST) .LE. 0.0) THEN
            IF (DEST.LE.DNODES) DISCR(NET,DEST,MODYR) = DISCR(NET,DEST,MODYR) - NODE_DMD(NET,DEST) + 1.
!YD1?            NODE_DMD(NET,DEST) = 1.       !YD1: THIS CONDITION CHANGES ZERO DMD AT LNG NODES MAKING BKSTOP>0
          ENDIF
          PFUEL(NET,DEST) = PFUEL_FAC(NET,DEST) * SCALE_PF(MODYR) * &
                 (NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)) * FE_PFUEL_FAC(MODYR)
          PFUEL(NET,DEST) = AMIN1(PFUEL(NET,DEST),0.15*NODE_DMD(NET,DEST) )
        ENDIF
       
        NODE_DMD(NET,DEST) = NODE_DMD(NET,DEST) + PFUEL(NET,DEST)

! TEMPCODE: 09/03/97
       INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST)
! TEMPCODE: 09/03/97

! CALCULATE SUPPLY SHARES AND CHECK AGAINST MAX SHARES (FLOWS)

        IF (SHR_OPT .EQ. 1) THEN               ! original method
          CALL NGSHR_CALC(DEST,NET)
        ELSE IF (SHR_OPT .EQ. 2) THEN          ! func (added net dmd)
          if (modyr .le. lhisyr) then          ! temp
            GAMMAFAC = 1.0                     ! temp
            CALL NGSHR_CALC(DEST,NET)          ! temp
          else                                 ! temp
            GAMMAFAC = GAMMATMP                ! temp
            CALL Z2NGSHR_CALC(DEST,NET)
          endif                                ! temp
        ELSE IF (SHR_OPT .EQ. 3) THEN          ! func (added net dmd): not good
          if (modyr .le. lhisyr) then          ! temp
            CALL NGSHR_CALC(DEST,NET)          ! temp
          else                                 ! temp
            CALL Z3NGSHR_CALC(DEST,NET)
          endif                                ! temp
        ELSE IF (SHR_OPT .EQ. 4) THEN          ! func (added rem cap)
          if (modyr .le. lhisyr) then          ! temp
            CALL NGSHR_CALC(DEST,NET)          ! temp
          else                                 ! temp
            CALL Z4NGSHR_CALC(DEST,NET)
          endif                                ! temp
        ELSE IF (SHR_OPT .EQ. 5) THEN          ! func (added rem cap)
          if (modyr .le. lhisyr) then          ! temp
            GAMMAFAC = 1.0                     ! temp
            CALL NGSHR_CALC(DEST,NET)          ! temp
          else                                 ! temp
            GAMMAFAC = GAMMATMP                ! temp
            CALL Z5NGSHR_CALC(DEST,NET)
          endif                                ! temp
        ELSE IF (SHR_OPT .EQ. 6) THEN          ! func (added net dmd)
          if (modyr .le. lhisyr) then          ! temp
            CALL NGSHR_CALC(DEST,NET)          ! temp
          else                                 ! temp
            CALL Z6NGSHR_CALC(DEST,NET)
          endif                                ! temp
        ENDIF

        IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN
          CALL NGSHR_LHISYR(DEST,NET)
         ELSE
          IF ((NET .EQ. PKNET) .AND. (MODYR.GT.NOBLDYR)) THEN    !utz
            MTH_CONS(NET,DEST) = MTH_CONS(NET,DEST) +       &    !utz
                                (PERMTH(NET) * PFUEL(NET,DEST))  !utz
            CALL NGSHR_MAXCHK(DEST,NET)                          !utz
            CALL NGSHR_MTHCHK(DEST,NET)                          !utz
          ELSE                                                   !utz
            CALL NGSHR_MAXCHK(DEST,NET)
          ENDIF                                                  !utz
        ENDIF

! SET ARC FLOWS AND ADD TO TOTAL DEMANDS AT SOURCE NODES.
! ALSO, ADD STORAGE SUPPLY IN PK TO NODE DMD IN OP.
! NOTE: NODE_DMD(1,STORAGE) ONLY USED TO TRACK STORAGE QTY.

        TFLOW = 0.0
        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          FLOW(NET,A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST)
          NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)
          IF ((NET.EQ.PKNET) .AND. (SRC.GT.(TNODES+SNODES))) THEN
            NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + FLOW(NET,A)
          ENDIF
! SET REMIANING FLOW
          IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)-.0001) THEN
              FLOW_REM(NET,A) = 0.0      ! REMAINING FLOW = 0
            ELSE
              FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A)
          ENDIF

          IF (SRC .LE. TNODES) THEN
              PFUEL_FLG(A) = 1     ! PIPEFUEL CONS ON THIS ARC
              TFLOW = TFLOW + FLOW(NET,A)
            ELSE
              PFUEL_FLG(A) = 0
          ENDIF
        ENDDO

! SET PIPEFUEL ALONG PIPE ARC ONLY
        DO A=ARC_1,ARC_2
          IF (PFUEL_FLG(A) .EQ. 1 .AND. TFLOW.GT.0.000001) THEN
              ARC_PFUEL(NET,A)= (PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST))* &
                                (FLOW(NET,A)/TFLOW)
            ELSE
              ARC_PFUEL(NET,A) = 0.0
          ENDIF
        ENDDO
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS
!
!  STATUS:  UNDER CONSTRUCTION
!
!  CALLED BY:  NGDOWN_TREE
!
!  FUNCTIONS USED:
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSHR_LHISYR(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc' 
      include 'nghistinc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A,I           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST, SRC     ! NODE ON TREE (SOURCE OR DEST NODE)
      INTEGER*4  CNT0          ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

      INTEGER*4  CHNG, CHK     ! FLAGS TO REDEFINE SHARES
      INTEGER*4  OLDFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)
      INTEGER*4  MAXFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHR
      INTEGER*4  CNBRD         ! AID IM MAPPING FR ARC TO BORDER XING

      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4     SUMSHR        ! TOTAL SHARES NOT AT MAX SHR
      REAL*4     SUMMAX        ! TOTAL SHARES AT MAX SHR
      REAL*4     SUMREM        ! TOTAL SHARES REMAINING FOR DISTRIBUTION
      REAL*4     TMAXFLO       ! TOTAL MAX FLOW INTO NODE

      REAL*4     TMPFLO        ! HOLDS PIPE FLOW TEMPORARILY
      REAL*4     SUMFAC        ! FACTOR (1,0) TO SET SHR=0 IF NEEDED

! -------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

! SET HISTORICAL SUPPLY SHR AND MAX SHR

      TMAXFLO = 0.0
      CHK = 0
!     NETDMD = NODE_DMD(NET,DEST)
      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        MAXFLG(A) = 0
        OLDFLG(A) = 0
!!!!    IF ((SRC .GT. TNODES) .AND. (SRC .LE. TNODES+SNODES)) THEN    ! SUPPLY
!!!x    IF (SRC .GT. TNODES) THEN    ! SUPPLY & STORAGE
!!!z    IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2)) THEN ! SUPPLY&STR
        IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2) .AND. &      !YD1: CHANGE IF OTHER SUPPLY BECOMES VARIABLE!!!!
            (SRC.NE.TNODES+SNODES-lSNODES-3)) THEN    ! SUP, STR, NOT CAN SUP
          MAXFLO(NET,A) = FLOW(NET,A)
          IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
            SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)
          ELSE
            SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2     ! temp, 10-26-05 ?????? OK?
          ENDIF
          SHR(NET,A,MODYR) = SHRMAX(A)
          TMAXFLO = TMAXFLO + MAXFLO(NET,A)
!         NETDMD = NETDMD - FLOW(NET,A)
!         OLDFLG(A) = 1
        ELSEIF (SRC.GT.DNODES .AND. SRC.LE.TNODES-LNGNODES-2 .AND. ARC_1.NE.ARC_2) THEN
          CNBRD = 0
          DO I=1,NXMAPUS
            IF (CAN_XMAPUS(I,2).EQ.SRC .AND. CAN_XMAPUS(I,1).EQ.DEST) CNBRD = I
          ENDDO
          IF (CNBRD.EQ.0) WRITE(6,*) ' NGCHECK MAP NGSHR_LHISYR ',SRC,DEST
          IF (NET.EQ.PKNET) THEN
            MAXFLO(NET,A) = HAFLOW(A,LHISYR) * HPKSHR_ICAN(LHISYR)
          ELSE
            MAXFLO(NET,A) = HAFLOW(A,LHISYR) * (1.-HPKSHR_ICAN(LHISYR))
          ENDIF 
          IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
            SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)
          ELSE
            SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2     ! temp, 10-26-05 ?????? OK?
          ENDIF
          SHR(NET,A,MODYR) = SHRMAX(A)
          TMAXFLO = TMAXFLO + MAXFLO(NET,A)
        ELSE                               ! PIPELINE ARCS                !YD1LNG: PROCESS LNG NODES DIFFERENTLY
          MAXFLO(NET,A) = NGSET_MAXFLO(NET,A)         ! FUNCTION
          IF (ARC_1 .NE. ARC_2) THEN
            TMPFLO = AMIN1((MAXFLO(NET,A)*.99999), &
                     (SHR(NET,A,MODYR)*NODE_DMD(NET,DEST)))
            IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
              SHR(NET,A,MODYR) = TMPFLO / NODE_DMD(NET,DEST)
            ELSE
              SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)  ! temp, 10-26-05 ?????? OK?
            ENDIF
          ENDIF
          IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
            SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)
          ELSE
            SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2     ! temp, 10-26-05 ?????? OK?
          ENDIF
          TMAXFLO = TMAXFLO + MAXFLO(NET,A)
!         OLDFLG(A) = 0
        ENDIF
      ENDDO

! check this

      IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN  ! DMD < TMAXFLO
        CHNG = 1
        DO WHILE (CHNG .EQ. 1)
          CHK = 0
          DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
            IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN
              SHR(NET,A,MODYR) = SHRMAX(A)     ! SET FLOW = MAX FLOW
              MAXFLG(A) = 1
              IF (MAXFLG(A) .NE. OLDFLG(A)) THEN
                CHK = 1
                OLDFLG(A) = MAXFLG(A)
              ENDIF
            ENDIF
          ENDDO

          IF (CHK .EQ. 1) THEN      ! NEED TO REALLOCATE SHR OVER ARCS
              SUMMAX = 0.0
              SUMREM = 0.0
              SUMSHR = 0.0

              CNT0 = 0
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  CNT0 = CNT0 + 1
                  SUMSHR = SUMSHR + SHR(NET,A,MODYR)
                ELSE
                  SUMMAX = SUMMAX + SHR(NET,A,MODYR)
                ENDIF
              ENDDO
              IF ((SUMMAX .GT. 1.0) .AND. (SUMSHR.GE. 0.0)) THEN
                SUMREM = 0.0
                SUMFAC = 0.0
               ELSE
                IF ((SUMSHR+SUMMAX) .GT. 1.0) THEN
                  SUMREM = 0.0
                  SUMFAC = (1.-SUMMAX) / SUMSHR
                 ELSE
                  SUMREM = 1. - (SUMSHR+SUMMAX)
                  SUMFAC = 1.0
                ENDIF
              ENDIF
                                      ! DISTRIBUTE OVER UNCONSTR ARCS
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  IF (SUMSHR .GT. 0.0) THEN
                    SHR(NET,A,MODYR) = (SUMFAC + (SUMREM/SUMSHR)) * &
                       SHR(NET,A,MODYR)
                  ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &
                           (CNT0 .GT. 0)) THEN
                    SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)
                  ENDIF
                ENDIF
              ENDDO
            ELSE
              CHNG = 0
          ENDIF
        ENDDO

      ELSE       ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

        BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO
!CCC    BKSTOP_FLG = 1

        DO A=ARC_1,ARC_2
          SHR(NET,A,MODYR) = SHRMAX(A)
        ENDDO

        WRITE(NGOERR,100)                   & ! ATTN
         MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), &
         TMAXFLO, RBKSTOP_PADJ(NET,DEST)
      ENDIF

  100 FORMAT(1X,'ATTN4--BKSTOP: YR,CYC,NET,NODE= ',I4,I3,I2,I3, &
         '   BKSTOP,DMD,MAX,PADJ= ', 3F10.4,F7.3)

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET REMAINING FLOW ALONG ARC
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGDOWN_TREE
!              HNGDOWN_TREE
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGSET_FLOWREM(NET,A)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A             ! COUNTERS
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC

      REAL*4     FAC           ! PK/OP FACTOR
! ----------

      SRC = ARC_2NODE(A,1)
      IF (NET .EQ. PKNET) THEN
                            ! REMAINING FLOW IN PK BASED ON CUR CAP
          IF (SRC .GT. (TNODES+SNODES)) THEN   ! STORAGE ARC
              FAC = PKUTZ(A)
            ELSE                               ! PIPELINE OR SUPPLY ARC
              FAC = PKSHR_YR * PKUTZ(A)
          ENDIF
          NGSET_FLOWREM = AMAX1( 0., FAC*CURPCAP(A,MODYR) - FLOW(NET,A))
        ELSE
                           ! REMAINING FLOW IN OP BASED ON MAX OP CAP
          NGSET_FLOWREM = AMAX1( 0., MAXFLO(NET,A) - FLOW(NET,A))
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET SECONDARY FLOWS OUT OF MIDDLE ATLANTIC
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

      SUBROUTINE NGSECFLOW2
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ngsteoinc'
      include 'nghistinc'
      include 'ogglobal'

      INTEGER*4  A,N            ! COUNTERS
      INTEGER*4  ARC_1,ARC_2    ! INPUT ARC COUNTERS
      INTEGER*4  DST(3)         ! THREE NODES WITH SEC FLOWS OUT OF SRC(3)
      INTEGER*4  SRC(4)         ! THREE NODES WITH SEC FLOWS INTO DST(3)
      INTEGER*4  DEST           ! SPECIFIC DESTINATION NODE
      INTEGER*4  NET            ! REPRESENTS PK,OP NETWORK
      INTEGER*4  I,J            ! COUNTERS
      INTEGER*4  ICNT           ! KEEP TRACK OF NUMBER OF ARCS GOING INTO DST
      INTEGER*4  ARCPRM         ! ARC NUMBER FOR PRIMARY ARC INTO DST
      INTEGER*4  ARCPRM2        ! ARC NUMBER FOR PRIMARY ARC ALONG SEC ARC INTO DST
      INTEGER*4  ARCSEC         ! ARC NUMBER FOR SECONDARY ARC OUT OF DST
      INTEGER*4  ARCSEC2        ! ARC NUMBER FOR SECOND SECONDARY ARC OUT OF DST

      REAL*4     INVPR_SUM      ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     SHRLAG(10)     ! LAST YEAR'S SHARES BASED ON FLWLAG
      REAL*4     SHRTST(10)     ! THIS YEAR'S SHARES IF KEY SEC FLOW INCLUDED
      REAL*4     REV_ARC_SHRPR  ! SHARE PRICE ALONG REVERSE FLOW ARC
      REAL*4     REV_ARC_SHRPR2 ! SHARE PRICE ALONG SECOND REVERSE FLOW INTO CANADA
      REAL*4     FLWTOT         ! TOTAL FLOW LAST ITERATION INTO NEW DEST ARC, INCL FROM 2
      REAL*4     SHRSUM         ! SUM OF NONNORMALIZED SHARES INTO NEW DEST ARC, INCLU FROM 2
      REAL*4     REV_FLOW(NETWORK,4)   ! FINAL FLOW BY NETWORK ON REVERSE FLOW ARC INTO DEST J
      REAL*4     FLWLAG(10,NETWORK,3)  ! FLOW INTO DEST LAST YEAR, INCL KEY SEC FLOW, 10 MAX NUMBER      
      REAL*4     FLWLAGTOT(NETWORK,3)  ! TOTAL FLOW LAST YEAR INTO NEW DEST ARC, INCL FROM 2      
      REAL*4     FLW(4)         ! HOLDING ARRAY
      REAL*4     MINFLW(4)      ! HOLD PRESET MINIMUM FLOW LEVELS
      real*4     price(10)

      DATA DST/3,5,23/
      DATA SRC/2,2,14,15/
! -------------

      DO NET = 1,NETWORK
        DO J=1,3
          SHRTST = 0.0
          SHRLAG = 0.0
          IF (CURITR.EQ.1) THEN
            DO I=1,10
              FLWLAG(I,NET,J) = 0.0
            ENDDO
          ENDIF
          PRICE = 0.0
          DEST = DST(J)
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)
          N = ARC_2 - ARC_1 + 1                    
          ARCPRM = NODE_2ARC(DEST,SRC(J))
          ARCSEC = SNODE_2ARC(SRC(J),DEST)

          IF (J.EQ.3) THEN
            ARCPRM2 = NODE_2ARC(DEST,SRC(J+1))
            ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST)
          ENDIF        

!!!!!     REV_ARC_SHRPR = NODE_SHRPR(NET,SRC(J)) + ARC_SHRFEE(NET,ARCPRM)
          REV_ARC_SHRPR = NODE_SHRPR(NET,SRC(J)) 

          IF (CURITR.EQ.1) THEN
            FLWLAG(N+1,NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET)
            FLWLAGTOT(NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET)              ! INITIALIZE
            IF (NET.EQ.PKNET) MINFLW(J) = SAFLOW(ARCSEC,MODYR-1)                ! ch to "-1" for conv prob, but now not used
          ELSE
            FLWTOT = SAFLOW(ARCSEC,MODYR) * SHRYR(NET)                   ! INITIALIZE
          ENDIF
          INVPR_SUM = (1. / REV_ARC_SHRPR) ** GAMMAFAC                   ! INITIALIZE
          price(n+1) = rev_arc_shrpr

          IF (J.EQ.3) THEN
                        ! don't have tariff for 3->23, so make assumption 
!!!!!!      REV_ARC_SHRPR2 = NODE_SHRPR(NET,3) + 0.50
            REV_ARC_SHRPR2 = NODE_SHRPR(NET,3) 

            IF (CURITR.EQ.1) THEN
              FLWLAG(N+2,NET,J) = SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET)
              FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET)  ! INITIALIZE
              IF (NET.EQ.PKNET) MINFLW(J+1) = SAFLOW(ARCSEC2,MODYR-1)           ! ch to "-1" for conv prob, but now not used
            ELSE
              FLWTOT = FLWTOT + SAFLOW(ARCSEC2,MODYR) * SHRYR(NET)          ! INITIALIZE
            ENDIF
            INVPR_SUM = INVPR_SUM + (1. / REV_ARC_SHRPR2) ** GAMMAFAC     ! INITIALIZE
            price(n+2) = rev_arc_shrpr2
          ENDIF

          ICNT = 0
          DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS
            ICNT = ICNT + 1
            IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN
              INVPR_SUM = INVPR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC)
              price(icnt) = arc_shrpr(net,a)
              IF (CURITR.EQ.1) THEN
                FLWLAG(ICNT,NET,J) = FLOW(NET,A)
                FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + FLOW(NET,A)
              ELSE
                FLWTOT = FLWTOT + FLOW(NET,A)
              ENDIF
            ELSE
              WRITE(4,*) ' NGERR NEG ARC_SHRPR ', NET,DEST
            ENDIF
          ENDDO
          DO I=1,N+1
            SHRLAG(I) = FLWLAG(I,NET,J) / FLWLAGTOT(NET,J)
          ENDDO
          IF (J.EQ.3) THEN
            SHRLAG(N+2) = FLWLAG(N+2,NET,J) / FLWLAGTOT(NET,J)
            SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+2) * &                
                  (((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM)        
            SHRTST(N+2)= SHRLAG(N+2) * FLOAT(N+2) * &                
                  (((1./REV_ARC_SHRPR2)**GAMMAFAC) / INVPR_SUM)        
            SHRSUM = SHRTST(N+1) + SHRTST(N+2)                  ! INITIALIZE          
          ELSE
            SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+1) * &                
                  (((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM)        
            SHRSUM = SHRTST(N+1)                                ! INITIALIZE
          ENDIF
          
          ICNT=0
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            ICNT = ICNT + 1
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                (INVPR_SUM .GT. 0.0)) THEN
              IF (J.EQ.3) THEN
                SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+2) * &
                  (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)
              ELSE 
                SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+1) * &
                  (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)
              ENDIF
              SHRSUM = SHRSUM + SHRTST(ICNT)
            ELSE
              WRITE(4,*) ' NGERR NEG INVPR_SUM ', NET,DEST
            ENDIF
          ENDDO

          IF (CURITR.EQ.1) FLWTOT = FLWLAGTOT(NET,J) 
          IF (SHRSUM .GT. 0.0) THEN
            REV_FLOW(NET,J) = FLWTOT * SHRTST(N+1) / SHRSUM       
            IF (J.EQ.3)  REV_FLOW(NET,J+1) = FLWTOT * SHRTST(N+2) / SHRSUM       
          ELSE
            REV_FLOW(NET,J) = 0.0
            IF (J.EQ.3) REV_FLOW(NET,J+1) = 0.0
          ENDIF
!         if (fcrl.eq.1) then
!           write(4,1234) modyr,curitr,net,j,(price(i),i=1,n+2)
!1234        format(1x,' JBE2 yr,itr,net,j ',4i5,10f6.2)
!           write(4,1236) modyr,curitr,net,j,(shrtst(i),i=1,n+2),shrsum
!1236        format(1x, ' JBE4 yr,itr,net,j ',4i5,11f6.3)
!         endif
        ENDDO
      ENDDO
      DO J=1,3
        DEST = DST(J)
        ARCSEC = SNODE_2ARC(SRC(J),DEST)
        ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST)
        FLW(J) = REV_FLOW(PKNET,J) + REV_FLOW(OPNET,J)
        IF (J.EQ.3) FLW(J+1) = REV_FLOW(PKNET,J+1) + REV_FLOW(OPNET,J+1)

!!!!!   SAFLOW(ARCSEC,MODYR) = AMAX1(FLW(J),MINFLW(J))                          ! not using minflw to deal with conv prob
!!!!!   IF (J.EQ.3) SAFLOW(ARCSEC2,MODYR) = AMAX1(FLW(J+1),MINFLW(J+1))
        SAFLOW(ARCSEC,MODYR) = FLW(J)
        IF (J.EQ.3) SAFLOW(ARCSEC2,MODYR) = FLW(J+1)
      ENDDO

      ARC_1 = SNODE_2ARC(2,14)
      ARC_2 = SNODE_2ARC(14,23)
      IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) THEN
        SAFLOW(ARC_2,MODYR) = CANEXP(2,MODYR) + CNFLOW_OUT(2,MODYR)
      ENDIF
      SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR)
      SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR))
      SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR))      
      CANEXP(2,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(2,MODYR)
      oOGQNGEXP(2,CURIYR) = CANEXP(2,MODYR)
      ARC_1 = SNODE_2ARC(3,15)
      ARC_2 = SNODE_2ARC(15,23)
      IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) THEN
        SAFLOW(ARC_2,MODYR) = CANEXP(3,MODYR) + CNFLOW_OUT(3,MODYR)
      ENDIF
      SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR)
      SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR))
      SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR))
      CANEXP(3,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(3,MODYR)
      oOGQNGEXP(3,CURIYR) = CANEXP(3,MODYR)

!     if (fcrl.eq.1) then 
!       IF (MODYR.EQ.LHISYR+1) WRITE(4,*) 'FLOW2    2->3     2->5    2->23    3->23'
!       WRITE(4,4344) MODYR,(FLW(J),J=1,4)
!4344    FORMAT (1X, 'FLOW2  ',I5,4F8.3)
!     endif
 
      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGDOWN_TREE
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK

      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     SHRSUM        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
! -------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      INVPR_SUM = 0.0
      N = ARC_2 - ARC_1 + 1
      
      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
          SHR(NET,ARC_1,MODYR) = 1.0
        ELSE
          DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS
            IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN
              INVPR_SUM = INVPR_SUM + &
                          ((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC)
            ENDIF
          ENDDO

          SHRSUM = 0.0
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                (INVPR_SUM .GT. 0.0)) THEN
              SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * &
                (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)
              SHRSUM = SHRSUM + SHR(NET,A,MODYR)
            ELSE
              SHR(NET,A,MODYR) = 0.0
            ENDIF
          ENDDO
          IF (SHRSUM .GT. 0.0) THEN
            DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
              SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM
            ENDDO
          ENDIF
      ENDIF
      
      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  << OPTION 2 >>
!  NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE
!
!  8/30/99
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE Z2NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW
      INTEGER*4  FLGSTOP       ! FLAG USED TO STOP DO LOOP
      INTEGER*4  LASTCYC       ! TRACKS WHEN NEW CYCLE BEGINS

      REAL*4     PR_SUM        ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     SUMSHR        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
      REAL*4     ADDSHR(ARCS)  ! SHR OF ADDED NET NODE_DMD
      REAL*4     ADDDMD(ARCS)  ! ADDED NET NODE_DMD
      REAL*4     TADDDMD       ! TOTAL ADDED DMD AT NODE FROM T-1
      REAL*4     NEWFLOW(ARCS) ! NEW FLOW INTO NODE
      REAL*4     FLOWNEG       ! TOTAL NEGATIVE FLOW

      REAL*4     MIN_PCTFLO    ! LOCAL VARIABLE FOR PCTFLO
! -------------

!CCC  IF (CYCLE .LE. 2) THEN
!CCC    MIN_PCTFLO = PCTFLO           ! PCT OF T-1 FLOW RETAINED IN T
!CCC    LASTCYC = CYCLE
!CCC  ELSE
!CCC    IF (CYCLE .NE. LASTCYC) THEN
!CCC      MIN_PCTFLO = MIN_PCTFLO + ((1.-MIN_PCTFLO) / 10.)
!CCC      LASTCYC = CYCLE
!CCC    ENDIF
!CCC  ENDIF

      MIN_PCTFLO = PCTFLO           ! PCT OF T-1 FLOW RETAINED IN T

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      PR_SUM = 0.0
      N = ARC_2 - ARC_1 + 1

      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
        SHR(NET,ARC_1,MODYR) = 1.0
      ELSE
        TADDDMD = NODE_DMD(NET,DEST) -  &
                 (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
        IF (TADDDMD .LE. 0.0) THEN
          MIN_PCTFLO = 0.95 * &
                    ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )
          TADDDMD = NODE_DMD(NET,DEST) -  &
                   (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
          IF (CYCLE .EQ. 1) THEN
            WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &
                   "FOR DEST, YEAR = ", DEST,MODYR
          ENDIF
        ENDIF
        IF (TADDDMD .GE. 0.0) THEN
                   ! NET DMD INCREASES
                   ! DEFINE SHR TO INCREASE FLOW AS [INVP/(SUM INVP)]
          DO A=ARC_1,ARC_2
            IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN
              PR_SUM = PR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC)
            ENDIF
          ENDDO

          SUMSHR = 0.0
          DO A=ARC_1,ARC_2
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                (PR_SUM .GT. 0.0)) THEN
              ADDSHR(A) = (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / &
                              PR_SUM)
            ELSE
              ADDSHR(A) = 0.0
            ENDIF
            SUMSHR = SUMSHR + ADDSHR(A)
          ENDDO
          IF (SUMSHR .GT. 0.0) THEN
            DO A=ARC_1,ARC_2
              ADDSHR(A) = ADDSHR(A) / SUMSHR
              ADDDMD(A) = ADDSHR(A) * TADDDMD
              NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)
            ENDDO
          ELSE
            DO A=ARC_1,ARC_2
              NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO       ! ???? wrong
            ENDDO
          ENDIF

                   ! NET DMD DECREASES, SO MAKE SURE FLOWS AREN'T < 0
                   ! DEFINE SHR TO DECREASE FLOW AS P/(SUM P)
        ELSE

          WRITE(NGOERR,*) " ERROR Z2NG: NEED TO CHECK CALC OF ", &
             "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &
              CURITR, CYCLE

        ENDIF     ! end check for added net dmd > 0

        DO A=ARC_1,ARC_2
          SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)
        ENDDO

!       CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)

      ENDIF       ! end check for single arc into node

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  << OPTION 3 >>
!  NEW SHARING ALGORITHM BASED ON ARC PRICES (OPT 1)
!  AND USING REMAINING FLOW (COMBINED OPT 2 & 4) for gammafac
!
!  8/30/99
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE Z3NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC INTO DEST NODE
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW
      INTEGER*4  FLGSTOP       ! FLAG USED TO STOP DO LOOP

      REAL*4     PR_SUM        ! TOTAL INVERSE PRICE FOR INPUT ARCS

      REAL*4     SUMSHR        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
      REAL*4     ADDSHR(ARCS)  ! SHR OF ADDED NET NODE_DMD
      REAL*4     ADDDMD(ARCS)  ! ADDED NET NODE_DMD
      REAL*4     TADDDMD       ! TOTAL ADDED DMD AT NODE FROM T-1
      REAL*4     NEWFLOW(ARCS) ! NEW FLOW INTO NODE
      REAL*4     FLOWNEG       ! TOTAL NEGATIVE FLOW

      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     PRV_REMCAP(ARCS)
      REAL*4     SUM_REMCAP
      REAL*4     ARC_GAMMAFAC(ARCS)
      REAL*4     CUR_EFFCAP(NETWORK,ARCS)    ! CURRENT EFFECTIVE CAPACITY
      REAL*4     MAX_EFFCAP(NETWORK,ARCS)    ! MAXIMUM EFFECTIVE CAPACITY
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC

      REAL*4     MIN_PCTFLO    ! LOCAL VARIABLE FOR PCTFLO
! -------------

      MIN_PCTFLO = PCTFLO           ! PCT OF T-1 FLOW RETAINED IN T
      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      PR_SUM = 0.0
      N = ARC_2 - ARC_1 + 1

      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
        SHR(NET,ARC_1,MODYR) = 1.0
      ELSE

! opt 4
                                     ! set & sum rem cap for t-1
          DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
            SRC = ARC_2NODE(A,1)
            MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)
            IF (NET .EQ. PKNET) THEN
              IF (SRC .GT. TNODES+SNODES) THEN        ! storage
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)
              ELSE IF(SRC .LE. TNODES) THEN         ! pipe
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR
              ELSE                                  ! supply
                CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
              ENDIF
            ELSE
              CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
            ENDIF
          ENDDO

          SUM_REMCAP = 0.0
          DO A=ARC_1,ARC_2
            IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN
              PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &
                               ALPHAFAC
            ELSE
              PRV_REMCAP(A) = 0.0
            ENDIF
            SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)
          ENDDO

          INVPR_SUM = 0.0
          DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS
            ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A)
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                  (CUR_EFFCAP(NET,A).GT. 0.0)) THEN
              INVPR_SUM = INVPR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A))
            ENDIF
          ENDDO

          SUMSHR = 0.0
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                  (INVPR_SUM .GT. 0.0) .AND. &
                  (CUR_EFFCAP(NET,A).GT. 0.0)) THEN
              ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) * &
                  (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)
            ELSE
              ADDSHR(A) = 0.0
            ENDIF
            SUMSHR = SUMSHR + ADDSHR(A)
          ENDDO
! opt 4
          IF (SUMSHR .GT. 0.0) THEN
            DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
              SHR(NET,A,MODYR) = ADDSHR(A) / SUMSHR
            ENDDO
          ELSE
            DO A=ARC_1,ARC_2
              SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)
            ENDDO
          ENDIF

      ENDIF       ! end check for single arc into node

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  USE SHARING ALGORITHM option 4 TO CALCULATE SHARES ALONG ARCS INTO NODES
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGDOWN_TREE
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE Z4NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ON ARC INTO DEST NODE
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK

      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     SHRSUM        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
      REAL*4     PRV_REMCAP(ARCS)
      REAL*4     SUM_REMCAP
      REAL*4     ARC_GAMMAFAC(ARCS)
      REAL*4     CUR_EFFCAP(NETWORK,ARCS)    ! CURRENT EFFECTIVE CAPACITY
      REAL*4     MAX_EFFCAP(NETWORK,ARCS)    ! MAXIMUM EFFECTIVE CAPACITY
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
! -------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      N = ARC_2 - ARC_1 + 1

      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
        SHR(NET,ARC_1,MODYR) = 1.0
      ELSE
                                     ! set & sum rem cap for t-1
        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)
          IF (NET .EQ. PKNET) THEN
            IF (SRC .GT. TNODES+SNODES) THEN        ! storage
              CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)
            ELSE IF(SRC .LE. TNODES) THEN         ! pipe
              CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR
            ELSE                                  ! supply
              CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
            ENDIF
          ELSE
            CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
          ENDIF
        ENDDO

        SUM_REMCAP = 0.0
        DO A=ARC_1,ARC_2
          IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN
            PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &
                             ALPHAFAC
          ELSE
            PRV_REMCAP(A) = 0.0
          ENDIF
          SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)
        ENDDO

        INVPR_SUM = 0.0
        DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS
          ARC_GAMMAFAC(A) = 1.0 - (PRV_REMCAP(A) / SUM_REMCAP)
          IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN
            INVPR_SUM = INVPR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A))
          ENDIF
        ENDDO

        SHRSUM = 0.0
        DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
          IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
              (INVPR_SUM .GT. 0.0)) THEN
            SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * &
              (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)
            SHRSUM = SHRSUM + SHR(NET,A,MODYR)
          ELSE
            SHR(NET,A,MODYR) = 0.0
          ENDIF
        ENDDO
        IF (SHRSUM .GT. 0.0) THEN
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM
          ENDDO
        ENDIF
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  << OPTION 5 >>
!  NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE
!  AND USING REMAINING FLOW FRACTION TIMES PRICE RATIOS
!
!  12/02/99
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE Z5NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC INTO DEST NODE
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW
      INTEGER*4  FLGSTOP       ! FLAG USED TO STOP DO LOOP

      REAL*4     PR_SUM        ! TOTAL INVERSE PRICE FOR INPUT ARCS

      REAL*4     SUMSHR        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
      REAL*4     ADDSHR(ARCS)  ! SHR OF ADDED NET NODE_DMD
      REAL*4     ADDDMD(ARCS)  ! ADDED NET NODE_DMD
      REAL*4     TADDDMD       ! TOTAL ADDED DMD AT NODE FROM T-1
      REAL*4     NEWFLOW(ARCS) ! NEW FLOW INTO NODE
      REAL*4     FLOWNEG       ! TOTAL NEGATIVE FLOW

      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1)
      REAL*4     ADJFAC_REMCAP ! ADJ FACTOR FR REM CAP IN OP
      REAL*4     SUM_REMCAP    ! TOTAL REMAINING CAPACITY
      REAL*4     ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC
      REAL*4     CUR_EFFCAP(NETWORK,ARCS)    ! CURRENT EFFECTIVE CAPACITY
      REAL*4     MAX_EFFCAP(NETWORK,ARCS)    ! MAXIMUM EFFECTIVE CAPACITY
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC

      REAL*4     MIN_PCTFLO    ! LOCAL VARIABLE FOR PCTFLO
! -------------

      MIN_PCTFLO = PCTFLO           ! PCT OF T-1 FLOW RETAINED IN T
      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      PR_SUM = 0.0
      N = ARC_2 - ARC_1 + 1

      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
        SHR(NET,ARC_1,MODYR) = 1.0
      ELSE
! opt 2
        TADDDMD = NODE_DMD(NET,DEST) -  &
                 (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
        IF (TADDDMD .LE. 0.0) THEN
          MIN_PCTFLO = 0.95 * &
                    ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )
          TADDDMD = NODE_DMD(NET,DEST) -  &
                   (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
          IF (CYCLE .EQ. 1) THEN
            WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &
                   "FOR DEST, YEAR = ", DEST,MODYR
          ENDIF
        ENDIF

        IF (TADDDMD .GE. 0.0) THEN       ! note: this is true from above calc
                   ! NET DMD INCREASES
! opt 4
                                     ! set & sum rem cap for t-1
          DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
            SRC = ARC_2NODE(A,1)
            MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)
            IF (NET .EQ. PKNET) THEN
              IF (SRC .GT. TNODES+SNODES) THEN        ! storage
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)
              ELSE IF(SRC .LE. TNODES) THEN         ! pipe
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR
              ELSE                                  ! supply
                CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
              ENDIF
            ELSE
              CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
            ENDIF
          ENDDO

          SUM_REMCAP = 0.0
          DO A=ARC_1,ARC_2
            IF (CUR_EFFCAP(NET,A) .GT. (MIN_PCTFLO*PRVFLOW(NET,A))) THEN
              PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - &
                 (MIN_PCTFLO*PRVFLOW(NET,A))) ** ALPHAFAC
            ELSE
              PRV_REMCAP(A) = 0.0
            ENDIF
            SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)
          ENDDO

          INVPR_SUM = 0.0
          DO A=ARC_1,ARC_2                ! LOOP OVER INPUT ARCS
            ARC_GAMMAFAC(A) = GAMMAFAC    ! tmp: hardcoded
            IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN
              INVPR_SUM = INVPR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A))
            ENDIF
          ENDDO

          SUMSHR = 0.0
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                (INVPR_SUM .GT. 0.0)) THEN
              IF (NET .EQ. PKNET) THEN
                ADJFAC_REMCAP = 1.0
              ELSE                ! add adj factor fr rem cap in OP
                ADJFAC_REMCAP = float(N) * PRV_REMCAP(A) / SUM_REMCAP
              ENDIF
              ADDSHR(A) = ADJFAC_REMCAP * &
                (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)
            ELSE
              ADDSHR(A) = 0.0
            ENDIF
            SUMSHR = SUMSHR + ADDSHR(A)
          ENDDO

          IF (SUMSHR .GT. 0.0) THEN
            DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
              ADDSHR(A) = ADDSHR(A) / SUMSHR
              ADDDMD(A) = ADDSHR(A) * TADDDMD
              NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)
            ENDDO
          ELSE
            DO A=ARC_1,ARC_2
              NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO
              WRITE(NGOERR,*) " NEWFLOW: ",MODYR," ",A," ",NEWFLOW(A), &
                   " ",NODE_DMD(NET,DEST)
            ENDDO
          ENDIF
        ELSE

          WRITE(NGOERR,*) " ERROR Z5NG: NEED TO CHECK CALC OF ", &
             "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &
              CURITR, CYCLE

        ENDIF

        DO A=ARC_1,ARC_2
          SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)
        ENDDO

!       CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)

      ENDIF       ! end check for single arc into node

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  << OPTION 6 >>
!  NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE
!  AND USING REMAINING FLOW (COMBINED OPT 2 & 4)
!
!  8/30/99
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE Z6NGSHR_CALC(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  A,N           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC INTO DEST NODE
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW
      INTEGER*4  FLGSTOP       ! FLAG USED TO STOP DO LOOP

      REAL*4     PR_SUM        ! TOTAL INVERSE PRICE FOR INPUT ARCS

      REAL*4     SUMSHR        ! SUM OF NEW SHR'S--USED FOR NORMALIZING
      REAL*4     ADDSHR(ARCS)  ! SHR OF ADDED NET NODE_DMD
      REAL*4     ADDDMD(ARCS)  ! ADDED NET NODE_DMD
      REAL*4     TADDDMD       ! TOTAL ADDED DMD AT NODE FROM T-1
      REAL*4     NEWFLOW(ARCS) ! NEW FLOW INTO NODE
      REAL*4     FLOWNEG       ! TOTAL NEGATIVE FLOW

      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS
      REAL*4     PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1)
      REAL*4     SUM_REMCAP    ! TOTAL REMAINING CAPACITY
      REAL*4     ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC
      REAL*4     CUR_EFFCAP(NETWORK,ARCS)    ! CURRENT EFFECTIVE CAPACITY
      REAL*4     MAX_EFFCAP(NETWORK,ARCS)    ! MAXIMUM EFFECTIVE CAPACITY
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC

      REAL*4     MIN_PCTFLO    ! LOCAL VARIABLE FOR PCTFLO
! -------------

      MIN_PCTFLO = PCTFLO           ! PCT OF T-1 FLOW RETAINED IN T
      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)
      PR_SUM = 0.0
      N = ARC_2 - ARC_1 + 1

      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE
        SHR(NET,ARC_1,MODYR) = 1.0
      ELSE
! opt 2
        TADDDMD = NODE_DMD(NET,DEST) -  &
                 (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
        IF (TADDDMD .LE. 0.0) THEN
          MIN_PCTFLO = 0.95 * &
                    ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )
          TADDDMD = NODE_DMD(NET,DEST) -  &
                   (MIN_PCTFLO * PRVNODE_DMD(NET,DEST))
          IF (CYCLE .EQ. 1) THEN
            WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &
                   "FOR DEST, YEAR = ", DEST,MODYR
          ENDIF
        ENDIF

        IF (TADDDMD .GE. 0.0) THEN
                   ! NET DMD INCREASES
! opt 4
                                     ! set & sum rem cap for t-1
          DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
            SRC = ARC_2NODE(A,1)
            MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)
            IF (NET .EQ. PKNET) THEN
              IF (SRC .GT. TNODES+SNODES) THEN        ! storage
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)
              ELSE IF(SRC .LE. TNODES) THEN         ! pipe
                CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR
              ELSE                                  ! supply
                CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
              ENDIF
            ELSE
              CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)
            ENDIF
          ENDDO

          SUM_REMCAP = 0.0
          DO A=ARC_1,ARC_2
            IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN
              PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &
                               ALPHAFAC
            ELSE
              PRV_REMCAP(A) = 0.0
            ENDIF
            SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)
          ENDDO

          INVPR_SUM = 0.0
          DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS
            ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A)
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                  (CUR_EFFCAP(NET,A).GT. 0.0)) THEN
              INVPR_SUM = INVPR_SUM + &
                        ((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A))
            ENDIF
          ENDDO

          SUMSHR = 0.0
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                  (INVPR_SUM .GT. 0.0) .AND. &
                  (CUR_EFFCAP(NET,A).GT. 0.0)) THEN
              ADDSHR(A) =  &
                  (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)
!AAAA         ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) *
!AAAA*            (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)
            ELSE
              ADDSHR(A) = 0.0
            ENDIF
            SUMSHR = SUMSHR + ADDSHR(A)
          ENDDO
! opt 4
          IF (SUMSHR .GT. 0.0) THEN
            DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
              ADDSHR(A) = ADDSHR(A) / SUMSHR
              ADDDMD(A) = ADDSHR(A) * TADDDMD
              NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)
            ENDDO
          ELSE
            DO A=ARC_1,ARC_2
              NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO
            ENDDO
          ENDIF
! opt 2
                   ! NET DMD DECREASES, SO MAKE SURE FLOWS AREN'T < 0
                   ! DEFINE SHR TO DECREASE FLOW AS P/(SUM P)
        ELSE

          WRITE(NGOERR,*) " ERROR Z6NG: NEED TO CHECK CALC OF ", &
             "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &
              CURITR, CYCLE

          DO A=ARC_1,ARC_2
            PR_SUM = PR_SUM + (ARC_SHRPR(NET,A) ** GAMMAFAC)
          ENDDO

          SUMSHR = 0.0
          DO A=ARC_1,ARC_2
            IF (PR_SUM .GT. 0.0) THEN
              ADDSHR(A) = (ARC_SHRPR(NET,A)**GAMMAFAC) / &
                              PR_SUM
            ELSE
              ADDSHR(A) = 0.0
            ENDIF
            SUMSHR = SUMSHR + ADDSHR(A)
          ENDDO
          IF (SUMSHR .GT. 0.0) THEN
            DO A=ARC_1,ARC_2
              ADDSHR(A) = ADDSHR(A) / SUMSHR
            ENDDO
          ELSE
            DO A=ARC_1,ARC_2
              ADDSHR(A) = 0.0
            ENDDO
          ENDIF
                  ! CHECK FOR NEGATIVE FLOW
          FLGSTOP = 0
          DO A=ARC_1,ARC_2
            FLGFLOW(A) = 1
          ENDDO

          DO WHILE (FLGSTOP .EQ. 0)
            FLOWNEG = 0.0
            SUMSHR = 0.0

            DO A=ARC_1,ARC_2
              IF (FLGFLOW(A) .EQ. 1) THEN
                ADDDMD(A) = ADDSHR(A) * TADDDMD
                NEWFLOW(A) = (PRVFLOW(NET,A)*MIN_PCTFLO) + ADDDMD(A)

                IF (NEWFLOW(A) .LT. 0.0) THEN
                  FLOWNEG = FLOWNEG + NEWFLOW(A)
                  NEWFLOW(A) = 0.0
                  ADDSHR(A) = 0.0
                  FLGFLOW(A) = 0
                ELSE
                  FLGFLOW(A) = 1
                  SUMSHR = SUMSHR + ADDSHR(A)
                ENDIF
              ENDIF
            ENDDO

            IF (FLOWNEG .GE. 0.0) THEN
              FLGSTOP = 1
            ELSE
              DO A=ARC_1,ARC_2
                IF (FLGFLOW(A) .EQ. 1) THEN
                  ADDSHR(A) = ADDSHR(A) / SUMSHR
                ENDIF
              ENDDO
            ENDIF
          ENDDO   ! end DO while flgstop = 0

        ENDIF     ! end check for added net dmd > 0

        DO A=ARC_1,ARC_2
          SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)
        ENDDO

      ENDIF       ! end check for single arc into node

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =           ! X
!                                                                   ! X
!  USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES  ! X
!                                                                   ! X
!  STATUS:  COMPLETE                                                ! X
!                                                                   ! X
!  CALLED BY:  NGDOWN_TREE                                          ! X
!                                                                   ! X
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =           ! X
      SUBROUTINE XNGSHR_CALC(DEST,NET)                              ! X
      IMPLICIT NONE                                                 ! X
                                                                    ! X
      include 'parametr'                                            ! x
      include 'ngparinc'                                            ! x
      include 'ngtdminc'                                            ! x
      include 'ngitminc'                                            ! x
                                                                    ! X
      INTEGER*4  A             ! COUNTERS                           ! X
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS                 ! X
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)           ! X
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK           ! X
                                                                    ! X
      REAL*4     INVPR_SUM     ! TOTAL INVERSE PRICE FOR INPUT ARCS ! X
                                                                    ! X
! -------------                                                     ! X
                                                                    ! X
      ARC_1 = ARC_LOOP(NET,DEST,1)                                  ! X
      ARC_2 = ARC_LOOP(NET,DEST,2)                                  ! X
      INVPR_SUM = 0.0                                               ! X
                                                                    ! X
      IF (ARC_1 .EQ. ARC_2) THEN     ! SINGLE ARC INTO NODE         ! X
          SHR(NET,ARC_1,MODYR) = 1.0                                ! X
        ELSE                                                        ! X
          DO A=ARC_1,ARC_2           ! LOOP OVER INPUT ARCS         ! X
            IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN                     ! X
              INVPR_SUM = INVPR_SUM + &
                          ((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC)     ! X
            ENDIF                                                   ! X
          ENDDO                                                     ! X
                                                                    ! X
          DO A=ARC_1,ARC_2        ! LOOP OVER ALL ARCS INTO DEST NODE
            IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &
                (INVPR_SUM .GT. 0.0)) THEN                          ! X
              SHR(NET,A,MODYR) = MUFAC* SHR(NET,A,MODYR-1)+ (1.-MUFAC)* &
                (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)     ! X
            ELSE                                                    ! X
              SHR(NET,A,MODYR) = 0.0                                ! X
            ENDIF                                                   ! X
          ENDDO                                                     ! X
      ENDIF                                                         ! X
                                                                    ! X
      RETURN                                                        ! X
      END                                                           ! X
                                                                    ! X
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS
!
!  STATUS:  UNDER CONSTRUCTION
!
!  CALLED BY:  NGDOWN_TREE
!
!  FUNCTIONS USED:
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSHR_MTHCHK(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A,D,I         ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST, SRC     ! NODE ON TREE (SOURCE OR DEST NODE)
      INTEGER*4  CHNG, CHK, C  ! FLAGS TO REDEFINE SHARES
      INTEGER*4  MAXFLG(ARCS)  ! FLAG INDICATING MAX CAP ON ARC

      REAL*4     TMTH_CAP
      REAL*4     TMTH_SHR
      REAL*4     TINIT_CAPADD
      REAL*4     INIT_CAPADD(ARCS)
      REAL*4     MTH_REDC
      REAL*4     MTH_CAP(ARCS)
      REAL*4     MTH_NETNOD(TNODES)
      REAL*4     MTHFLW(ARCS)
      REAL*4     MTH_CAPADD(NETWORK,ARCS)
      REAL*4     MTH_TCAPADD
!     REAL*4     NEW_MTHCAP(NETWORK,ARCS)
      REAL*4     NEW_MTHCAP(ARCS)
      REAL*4     MTH_EXFLW
      REAL*4     T_MTHFLW
      REAL*4     CUR_PERCAP(ARCS)
      REAL*4     NEW_PERCAP(ARCS)
      REAL*4     PER_CAPADD(ARCS)
      REAL*4     PERFAC
      REAL*4     ALLOWBLD
      REAL*4     NEW_EXFLW
      REAL*4     NEWT_MTHFLW
      REAL*4     ADDFLW

      REAL*4     MTH_MAXCAP(ARCS)
      REAL*4     TMTH_MAXCAP
      REAL*4     MTHDMD24       ! PKMTH demand at node 24
      REAL*4     MTHSTR(STNODES)! PKMTH storage
      REAL*4     TMTH_STR       ! total PKMTH storage
      REAL*4     WXBLD          ! extra builds due to weather factor

      INTEGER*4 W,V
      LOGICAL   TMPSET/.TRUE./
! -------------

      IF (TMPSET) THEN
        TMPSET = .FALSE.
        ALLOWBLD = 1.0
        IF (MODYR .LE. NOBLDYR) THEN
          WXBLD = 0.0
        ELSE
          WXBLD = XBLD
        ENDIF
      ENDIF

      TMTH_CAP = 0.0          ! INITIALIZE TOTAL PIPELINE MONTHLY CAP
      TMTH_SHR = 0.0          ! INITIALIZE TOTAL SHR
      TINIT_CAPADD = 0.0      ! INITIALIZE TOTAL PIPE CAP ADDITIONS

      TMTH_MAXCAP = 0.0

      IF (NET .EQ. PKNET) THEN
        PERFAC = PKSHR_YR
      ELSE
        PERFAC = 1.-PKSHR_YR
      ENDIF

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

! REDUCE MONTHLY CONS BY MONTHLY SUP AND STR FLOWS
      MTH_REDC = 0.0
      IF (NGDBGITR(4,7)) THEN
       write(ngoerr,*) "ATTN11: YR,ITR,DEST,NODE_DMD,MTH_CONS,%= ", &
        MODYR," ",CURITR," ",DEST," ",NODE_DMD(NET,DEST)," ", &
        MTH_CONS(NET,DEST)," ",MTH_CONS(NET,DEST)/NODE_DMD(NET,DEST)
      ENDIF

      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        IF (SRC .GT. TNODES+SNODES) THEN    ! STORAGE
          MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &
                   NODE_DMD(NET,DEST) * SPERMTH(NET,DEST))
        ELSE IF (SRC .GT. TNODES) THEN     ! SUPPLY
          MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &
                   NODE_DMD(NET,DEST) * PPERMTH(NET,SRC-TNODES)) !by sup reg
!!                 NODE_DMD(NET,DEST) * PPERMTH(NET,DEST))       !by ng reg

        ELSE                               ! PIPELINE ARCS
          CUR_PERCAP(A) = PERFAC * CURPCAP(A,MODYR)
          NEW_PERCAP(A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST) ! don't use xbld here
          IF (NEW_PERCAP(A) .GT. CUR_PERCAP(A)) THEN
                                 ! ALLOWBLD=1 unless want to restrict blds
            PER_CAPADD(A) = ALLOWBLD * (NEW_PERCAP(A) - CUR_PERCAP(A))
          ELSE
            PER_CAPADD(A) = 0.0
          ENDIF

          MTH_CAP(A) = PERMTH(NET) * (CUR_PERCAP(A) + PER_CAPADD(A))
          TMTH_CAP = TMTH_CAP + MTH_CAP(A)

          MTH_MAXCAP(A) = PERMTH(NET) * PERFAC * MAXPCAP(NET,A)
          TMTH_MAXCAP = TMTH_MAXCAP + MTH_MAXCAP(A)

          TMTH_SHR = TMTH_SHR + SHR(NET,A,MODYR)
        ENDIF
      ENDDO
                                            ! PIPELINE ARCS
      MTH_NETNOD(DEST) = (MTH_CONS(NET,DEST) - MTH_REDC) * &
                         (1. + WXBLD)       ! weather impact on dmd

      IF (MTH_NETNOD(DEST) .GE. (TMTH_MAXCAP+0.001)) THEN
                                            ! keep this write
        WRITE(NGOERR,30) DEST,modyr,curitr, &
                         mth_netnod(dest),tmth_maxcap,tmth_cap
   30   FORMAT (1X,'ATTN9: NGSHR_MTHCHK MAX CAP ERROR, dest=', &
          I4,' year,itr= ',I4,I4,' mth_netnod(dest),tmth_maxcap,tmth_cap ', &
          3F10.2)
      ENDIF

! IF CANADIAN NODE 24, REDEFINE STR PKMTH FACTOR (SPERMTH)
      IF (DEST .EQ. TNODES-LNGNODES) THEN   ! Canadian node 24
!       IF (NGDBGITR(4,7)) THEN
          WRITE(NGOERR,40) MTH_NETNOD(DEST), MTH_REDC, DEST, &
           modyr,curitr
   40     FORMAT (1X,'ATTN10: NGSHR_MTHCHK MTH_NETNOD demand, ', &
           'MTH_REDC ', 2F10.2, 'for region ', I4,' in year,itr ', 2I4)
!       ENDIF
        IF (ABS(MTH_NETNOD(DEST) / MTH_REDC) .GT. .01) THEN
                                            ! redefine str PKMTH factor
          TMTH_STR = 0.0
          DO I=1,STNODES
            D = STR_2NODE(I)
            A = NODE_2ARC(TNODES+SNODES+I,D)
            MTHSTR(I) = (SHR(NET,A,MODYR) * (1. +WXBLD) * &
                NODE_DMD(NET,D) * SPERMTH(NET,D))
            TMTH_STR = TMTH_STR + MTHSTR(I)
            IF (D .EQ. TNODES-LNGNODES) THEN ! Canadian node 24
              MTHDMD24 = MTH_NETNOD(D)
            ENDIF
          ENDDO
          DO I=1,STNODES
            D = STR_2NODE(I)
            SPERMTH(NET,D) = SPERMTH(NET,D) * &
                ((TMTH_STR + MTHDMD24) / TMTH_STR)
            IF (I .EQ. 14) THEN
              WRITE(NGOERR,50) D,SPERMTH(NET,D),MTHSTR(I),TMTH_STR
   50         FORMAT (1X,'ATTN10: NGSHR_MTHCHK new SPERMTH for reg ', &
               I4,' = ',F10.7,' MTHSTR= ',F10.2, ' TMTH_STR= ',F10.2)
            ENDIF
            IF (NGDBGITR(4,7)) THEN
              WRITE(NGOERR,*) "ATTN10: NGSHR_MTHCHK new SPERMTH for", &
               " reg ",D," = ",SPERMTH(NET,D)," MTHSTR= ",MTHSTR(I), &
               " TMTH_STR= ",TMTH_STR
            ENDIF
          ENDDO

        ENDIF
      ENDIF

! TOTAL MONTHLY PIPELINE CAP ADDITIONS NEEDED
      MTH_TCAPADD = AMAX1( (MTH_NETNOD(DEST) - TMTH_CAP), 0.0 )

      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN           ! PIPELINE ARCS
          IF (TMTH_SHR .GT. 0.0) THEN
            MTHFLW(A) = MTH_NETNOD(DEST) * &
                        (SHR(NET,A,MODYR) / TMTH_SHR)
          ELSE
            MTHFLW(A) = 0.0
          ENDIF
          INIT_CAPADD(A) = AMAX1( (MTHFLW(A) - MTH_CAP(A)), 0.0 )
          TINIT_CAPADD = TINIT_CAPADD + INIT_CAPADD(A)
        ENDIF
      ENDDO

! SET NEW CAPACITY ALONG PIPELINE ARCS

      DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN           ! PIPELINE ARCS
          IF (TINIT_CAPADD .GT. 0.0) THEN
            MTH_CAPADD(NET,A)  = MTH_TCAPADD * &
                (INIT_CAPADD(A) / TINIT_CAPADD)
          ELSE
            MTH_CAPADD(NET,A)  = 0.0
          ENDIF
          NEW_MTHCAP(A) = MTH_CAP(A) + MTH_CAPADD(NET,A)

          IF (NGDBGITR(4,7)) THEN
            WRITE(NGOERR,22) MODYR,CURITR,SRC,DEST,  &
             MTH_CAP(A),NEW_MTHCAP(A),MTH_MAXCAP(A)
          ENDIF
   22 FORMAT(' ATTN22: YR,ITR,SRC,DEST,MTHCAP,NEW_,MAX_= ', &
             I4,I4,I4,I4,3F10.3)

        ENDIF
      ENDDO


! CHECK IF NEW_MTHCAP > MTH_MAXCAP

      CALL NGFLW_MTHMAX(1,NET,DEST,NEW_MTHCAP,MTH_MAXCAP)

! CHECK IF MONTHLY FLOWS EXCEED MONTHLY PK CAP AND REALLOCATE

      CALL NGFLW_MTHMAX(2,NET,DEST,MTHFLW,NEW_MTHCAP)

! ADD MONTHLY FLOWS TO MONTHLY SRC PK DEMAND NODE
! AND ADD EXTRA CAPACITY AS CONTINGENCY

      DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN           ! PIPELINE ARCS
          MTH_CONS(NET,SRC) = MTH_CONS(NET,SRC) + &
                              MTHFLW(A) /(1. + WXBLD)  ! rmv weather impact on dmd
        ENDIF
                            ! stores new annual cap in opnet position
        IF (SRC .LE. DNODES) THEN           ! PIPELINE ARCS
          IF (NET .EQ. PKNET) THEN
            MAXPCAP(OPNET,A) = NEW_MTHCAP(A) / (PERMTH(NET)*PERFAC)
            IF (MAXPCAP(OPNET,A) .GT. MAXPCAP(PKNET,A)) THEN
              MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)
            ENDIF
          ENDIF
        ENDIF
      ENDDO

      RETURN
      END

! ==========================================================
!
!  CHECK IF MAXIMUM FLOW OR CAPACITY IS EXCEEDED AND REALLOCATE
!
! ==========================================================

      SUBROUTINE NGFLW_MTHMAX(ID,NET,DEST,FLW,CAP)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'

      INTEGER*4 ID, NET, DEST, SRC
      INTEGER*4 A, ARC_1, ARC_2
      INTEGER*4 C, CHNG, CHK
      INTEGER*4 MAXFLG(ARCS)
      INTEGER*4 CNT               ! count number of pipeline arcs into node

      REAL*4 FLW(ARCS)
      REAL*4 CAP(ARCS)
      REAL*4 ADDFLW
      REAL*4 EXFLW
      REAL*4 T_FLW
      REAL*4 NEW_EXFLW
      REAL*4 NEWT_FLW
! ------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

      CNT=0
      DO A=ARC_1,ARC_2      ! COUNT NUM OF PIPELINE ARCS INTO NODE
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN
          CNT = CNT+1
        ENDIF
      ENDDO

      IF (CNT .LE. 1) THEN  ! IF ONLY 1 PIPELINE ARC, CANNOT REALLOCATE
        RETURN
      ENDIF

      EXFLW = 0.0
      T_FLW = 0.0
      DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN           ! PIPELINE ARCS
          IF (FLW(A) .GE. CAP(A)) THEN
              EXFLW = EXFLW + (FLW(A)-CAP(A))
              FLW(A) = CAP(A)
              MAXFLG(A) = 1
            ELSE
              T_FLW = T_FLW + FLW(A)
              MAXFLG(A) = 0
          ENDIF
        ENDIF
      ENDDO

      C = 1
      CHNG = 1
      DO WHILE ((CHNG .EQ. 1) .AND. (C .LE. 20))
        CHK = 0

        NEW_EXFLW = 0.0
        NEWT_FLW = 0.0
        DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          IF (SRC .LE. TNODES) THEN           ! PIPELINE ARCS
            IF (MAXFLG(A) .EQ. 0) THEN
              ADDFLW = EXFLW * (FLW(A) / T_FLW)
              IF (ADDFLW .GE. (CAP(A) - FLW(A))) THEN
                  CHK = 1
                  MAXFLG(A) = 1
                  NEW_EXFLW = NEW_EXFLW + (ADDFLW - &
                              (CAP(A) - FLW(A)))
                  FLW(A) = CAP(A)
                ELSE
                  FLW(A) = FLW(A) + ADDFLW
                  NEWT_FLW = NEWT_FLW + FLW(A)
              ENDIF

            ENDIF
          ENDIF
        ENDDO

        EXFLW = NEW_EXFLW
        T_FLW  = NEWT_FLW
        CHNG = CHK
        C = C+1
      ENDDO

      IF (C .GT. 20) THEN
        WRITE(NGOERR,*) "ATTN8: MTH CAP REALLC INCOMPLETE FOR ", &
         MODYR, CURITR, " NET= ",NET, " DEST= ",DEST," ID= ",ID
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGDOWN_TREE
!
!  FUNCTIONS USED:  NGSET_MAXFLO
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSHR_MAXCHK(DEST,NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A             ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST, SRC     ! NODE ON TREE (SOURCE OR DEST NODE)
      INTEGER*4  CNT0          ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

      INTEGER*4  CHNG, CHK     ! FLAGS TO REDEFINE SHARES
      INTEGER*4  OLDFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)
      INTEGER*4  MAXFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHR

      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4     SUMSHR        ! TOTAL SHARES NOT AT MAX SHR
      REAL*4     SUMMAX        ! TOTAL SHARES AT MAX SHR
      REAL*4     SUMREM        ! TOTAL SHARES REMAINING FOR DISTRIBUTION
      REAL*4     TMAXFLO       ! TOTAL MAX FLOW INTO NODE

! -------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

      TMAXFLO = 0.0
      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        OLDFLG(A) = 0.
        MAXFLG(A) = 0.
        MAXFLO(NET,A) = NGSET_MAXFLO(NET,A)         ! FUNCTION
        IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
          SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)
        ELSE
          SHRMAX(A) = SHR(NET,A,MODYR) * 1.2        ! temp ???????? OK?
        ENDIF
        TMAXFLO = TMAXFLO + MAXFLO(NET,A)
      ENDDO

      IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN  ! DMD < TMAXFLO
        CHNG = 1
        DO WHILE (CHNG .EQ. 1)
          CHK = 0
          DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
            IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN
              SHR(NET,A,MODYR) = SHRMAX(A)     ! SET FLOW = MAX FLOW
              MAXFLG(A) = 1
              IF (MAXFLG(A) .NE. OLDFLG(A)) THEN
                CHK = 1
                OLDFLG(A) = MAXFLG(A)
              ENDIF
            ENDIF
          ENDDO

          IF (CHK .EQ. 1) THEN      ! NEED TO REALLOCATE SHR OVER ARCS
              SUMMAX = 0.0
              SUMREM = 0.0
              SUMSHR = 0.0

              CNT0 = 0
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  CNT0 = CNT0 + 1
                  SUMSHR = SUMSHR + SHR(NET,A,MODYR)
                ELSE
                  SUMMAX = SUMMAX + SHR(NET,A,MODYR)
                ENDIF
              ENDDO
              SUMREM = 1. - (SUMSHR+SUMMAX)
                                      ! DISTRIBUTE OVER UNCONSTR ARCS
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  IF (SUMSHR .GT. 0.0) THEN
                    SHR(NET,A,MODYR) = (1. + (SUMREM/SUMSHR)) * &
                                       SHR(NET,A,MODYR)
                  ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &
                           (CNT0 .GT. 0)) THEN
                    SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)
                  ENDIF
                ENDIF
              ENDDO
            ELSE
              CHNG = 0
          ENDIF
        ENDDO

      ELSE       ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

        BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO
!CCC    BKSTOP_FLG = 1

        DO A=ARC_1,ARC_2
          SHR(NET,A,MODYR) = SHRMAX(A)
        ENDDO

        WRITE(NGOERR,100)                   & ! ATTN
         MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), &
         TMAXFLO, RBKSTOP_PADJ(NET,DEST)
      ENDIF

  100 FORMAT(1X,'ATTN4--BKSTOP: YR,CYC,NET,NODE= ',I4,I3,I2,I3, &
         '   BKSTOP,DMD,MAX,PADJ= ', 3F10.4,F7.3)

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGDOWN_TREE
!
!  FUNCTIONS USED:  NGSET_MAXFLO
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE ZNGSHR_MAXCHK(DEST,NET,ADDSHR)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A             ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST, SRC     ! NODE ON TREE (SOURCE OR DEST NODE)
      INTEGER*4  CNT0          ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

      INTEGER*4  CHNG, CHK     ! FLAGS TO REDEFINE SHARES
      INTEGER*4  OLDFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)
      INTEGER*4  MAXFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHR

      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4     SUMSHR        ! TOTAL SHARES NOT AT MAX SHR
      REAL*4     SUMREM        ! TOTAL SHARES REMAINING FOR DISTRIBUTION
      REAL*4     TMAXFLO       ! TOTAL MAX FLOW INTO NODE
      REAL*4     ADDSHR(ARCS)  ! SHARES OF FLOW ADDED TO T-1
! -------------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

      TMAXFLO = 0.0
      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        OLDFLG(A) = 0.
        MAXFLG(A) = 0.
        MAXFLO(NET,A) = NGSET_MAXFLO(NET,A)         ! FUNCTION
        IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN
          SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)
        ELSE
          SHRMAX(A) = SHR(NET,A,MODYR) * 1.2        ! temp ???????? OK?
        ENDIF
        TMAXFLO = TMAXFLO + MAXFLO(NET,A)
      ENDDO

      IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN  ! DMD < TMAXFLO

        CHNG = 1
        DO WHILE (CHNG .EQ. 1)
          CHK = 0
          SUMREM = 0.0
          DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
            IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN
              SUMREM = SUMREM + (SHRMAX(A) - SHR(NET,A,MODYR))
              SHR(NET,A,MODYR) = SHRMAX(A)     ! SET FLOW = MAX FLOW
              MAXFLG(A) = 1
              IF (MAXFLG(A) .NE. OLDFLG(A)) THEN
                CHK = 1
                OLDFLG(A) = MAXFLG(A)
              ENDIF
            ENDIF
          ENDDO

          IF (CHK .EQ. 1) THEN      ! NEED TO REALLOCATE SHR OVER ARCS
              SUMSHR = 0.0
              CNT0 = 0
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  CNT0 = CNT0 + 1
                  SUMSHR = SUMSHR + ADDSHR(A)
                ENDIF
              ENDDO

                                      ! DISTRIBUTE OVER UNCONSTR ARCS
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                IF (MAXFLG(A) .EQ. 0) THEN
                  IF (SUMSHR .GT. 0.0) THEN
                    SHR(NET,A,MODYR) = (SUMREM*ADDSHR(A)/SUMSHR) + &
                        SHR(NET,A,MODYR)
                  ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &
                           (CNT0 .GT. 0)) THEN
                    SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)
                  ENDIF
                ENDIF
              ENDDO
            ELSE
              CHNG = 0
          ENDIF
        ENDDO
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGSHR_MAXCHK
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGSET_MAXFLO(NET,A)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4 NET        ! REPRESENTS PK, OP NETWORK
      INTEGER*4 A          ! COUNTER
      INTEGER*4 SRC        ! NODE ON TREE (SOURCE)
      INTEGER*4 DEST       ! NODE ON TREE (DESTINATION)

      REAL*4    PKFAC      ! ANNUAL TO PK SEASON CONVERSION
      REAL*4    OPFAC      ! ANNUAL TO OP SEASON CONVERSION
      REAL*4    XCAP       ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW
      REAL*4    DELXCAP    ! EXTRA CAP BUILD DUE TO WEATHER

      REAL*4    XNGSET_MAXFLO  !utz
! ---------

      NGSET_MAXFLO = XNGSET_MAXFLO(NET,A)       !utz
      RETURN                                    !utz


      SRC = ARC_2NODE(A,1)
      DEST= ARC_2NODE(A,2)

      IF (SRC .GT. (TNODES+SNODES)) THEN   ! STORAGE ARC
        PKFAC = PKUTZ(A)
        OPFAC = OPUTZ(A)                   ! NOTE: = 0.0
      ELSE                                 ! PIPELINE OR SUPPLY ARC
        PKFAC = PKSHR_YR * PKUTZ(A)
        OPFAC = (1.-PKSHR_YR) * OPUTZ(A)
      ENDIF

      IF (NET .EQ. PKNET) THEN             ! PEAK
        NGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC
      ELSE                                 ! OFFPEAK
        IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR.    &
          ((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN         ! SUPPLY (NO LNG)-or- FLORIDA
                                           ! NO CURPCAP FOR SUPPLY
          MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

        ELSE                               ! PIPE AND STORAGE
          XCAP = FLOW(PKNET,A) / PKFAC
          IF (XCAP .GT. CURPCAP(A,MODYR)) THEN
            MAXPCAP(OPNET,A) = XCAP
          ELSE
            MAXPCAP(OPNET,A) = CURPCAP(A,MODYR)
          ENDIF
        ENDIF
        NGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE
!
!  STATUS:  used with monthly calculation of cap adds
!
!  CALLED BY:  NGSHR_MAXCHK
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION XNGSET_MAXFLO(NET,A)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4 NET        ! REPRESENTS PK, OP NETWORK
      INTEGER*4 A          ! COUNTER
      INTEGER*4 SID        ! NODE ON SUPPLY COUNT (1-97)
      INTEGER*4 LID        ! NODE ON LNG SUPPLY COUNT (1-3)
      INTEGER*4 SRC        ! NODE ON TREE (SOURCE)
      INTEGER*4 DEST       ! NODE ON TREE (DESTINATION)

      REAL*4    PKFAC      ! ANNUAL TO PK SEASON CONVERSION
      REAL*4    OPFAC      ! ANNUAL TO OP SEASON CONVERSION

      REAL*4    XCAP       ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW
      REAL*4    DELXCAP    ! EXTRA CAP BUILD DUE TO WEATHER
      REAL*4    OPCAP      ! PLACEHOLDER FOR NEW ANNUAL CAP
! ---------

      SRC = ARC_2NODE(A,1)
      DEST= ARC_2NODE(A,2)

      IF (SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARC
        PKFAC = PKUTZ(A)
        OPFAC = OPUTZ(A)                 ! NOTE: = 0.0
      ELSE                               ! PIPELINE OR SUPPLY ARC
        PKFAC = PKSHR_YR * PKUTZ(A)
        OPFAC = (1.-PKSHR_YR) * OPUTZ(A)
      ENDIF

      SID = SRC-TNODES                   ! SUPPLY NODE COUNT (1-97)
      IF (SID .GE.FSRGN(14) .AND. SID .LE.FSRGN(14)+NSRGN(14)-1) THEN  ! LNG SUPPLY   !JBEMAX
        LID = SID - FSRGN(14)+1          ! LNG SUPPLY COUNT (1-3)
        XNGSET_MAXFLO = MAXPLNG(LID,NET,MODYR)                         !JBEMAX
      ELSE                                                             !JBEMAX
        IF (NET .EQ. PKNET) THEN           ! PEAK
          XNGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC
        ELSE                               ! OFFPEAK
          IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR.    &
            ((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN         ! SUPPLY -or- FLORIDA
                                           ! NO CURPCAP FOR SUPPLY
            MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)
                                           ! storage, imports, or nobldyr
          ELSE
            XCAP = FLOW(PKNET,A) / PKFAC
            IF (XCAP .GT. CURPCAP(A,MODYR)) THEN
              OPCAP = XCAP
            ELSE
              OPCAP = CURPCAP(A,MODYR)
            ENDIF                                                         !xutz
            IF ((SRC.LE.DNODES) .AND.(MAXPCAP(OPNET,A).GT.OPCAP)) THEN    !xutz
              WRITE(NGOERR,60) MODYR,SRC,DEST,MAXPCAP(OPNET,A),OPCAP      !xutz
   60         FORMAT(1X,'XNGSET_MAXFLO: YR,SRC,DEST,MAX,OPCAP', &         !xutz
                3I5,2F10.2)                                               !xutz
              CONTINUE       ! use value set in NGSHR_MTHCHK              !xutz
            ELSE                                                          !xutz
              MAXPCAP(OPNET,A) = OPCAP
            ENDIF
          ENDIF
          XNGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC
        ENDIF
      ENDIF                                                           !JBEMAX

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  CHECK CONVERGENCE ON SUPPLY PRICE
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  CALLS    :  NGSET_SUPPR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGCHK_CONVNG
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'

      REAL*4     DELTA          ! DIFFERENCE BTWN CURRENT & PREV SUP PR

      INTEGER*4  N,S            ! COUNTERS
      INTEGER*4  NET            ! NETWORK ID (1=PK, 2=OP)
      INTEGER*4  CFLG           ! CONVERGE FLAG FOR CYCLING UP/DOWN TREE

! -----------

      DO NET=1,NETWORK
        DO N=1,NODES
          NODE_ENDPR(NET,N) = 0.0
          NODE_SHRPR(NET,N) = 0.0
        ENDDO
      ENDDO

      DO NET=1,NETWORK
        DO S=1,SNODES
          N = TNODES + S
          IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N)
        ENDDO
      ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

      CALL NGSET_SUPPR

!  SET SCALE FACTOR FOR L48 & OFFSHORE WELLHEAD PRICE

      IF (MODYR .GT. EHISYR) THEN
        CALL NGSTEO_BENCHWPR
      ENDIF

! CHECK FOR CONVERGENCE IF CYCLE > 1

      DO NET=1,NETWORK
        DO S=1,SNODES
         IF (SUPARRAY(S).EQ.1) THEN
          PSUP_CNVG(NET,S) = 1
          QSUP_CNVG(NET,S) = 1
         ENDIF
        ENDDO
      ENDDO

      CFLG = 1

      IF (CYCLE .GT. 1) THEN

        DO NET=1,NETWORK
          DO S=1,SNODES              ! LOOP OVER SUPPLY NODES
           IF (SUPARRAY(S).EQ.1) THEN 
            DELTA = ABS(NODE_PSUP(NET,S) - NODE_PSUPPREV(NET,S)) / &
                    NODE_PSUPPREV(NET,S)
            IF (DELTA .LE. PSUP_DELTA) THEN
              PSUP_CNVG(NET,S) = 1
            ELSE
              PSUP_CNVG(NET,S) = 0
              QSUP_CNVG(NET,S) = 0
              CFLG = 0
              IF (NODE_QSUP(NET,S) .LE. (QSUP_SMALL*SHRYR(NET))) THEN
                DELTA = ABS(NODE_QSUP(NET,S)-NODE_QSUPPREV(NET,S)) / &
                            NODE_QSUPPREV(NET,S)
                IF (DELTA .LE. QSUP_DELTA) THEN
                  QSUP_CNVG(NET,S) = 1
                  CFLG = 1
                ENDIF
              ENDIF
            ENDIF
            IF (CFLG.EQ.0) GO TO 100
           ENDIF
          ENDDO
        ENDDO
        DO NET=1,NETWORK
          DO N=1,TNODES
            IF (BKSTOP(NET,N) .GT. 0.0) THEN
              CFLG = 0
            ENDIF
          ENDDO
        ENDDO

 100    CONTINUE

! IF NOT CONVERGED, SET NEW RELAXED SUPPLY QTY AND
! GET NEW WELLHEAD PRICE BEFORE GOING UP TREE

        IF (CFLG .EQ. 0) THEN
!CCC    IF ((CFLG .EQ. 0) .OR. (BKSTOP_FLG .EQ. 1)) THEN
!CCC      IF (BKSTOP_FLG .EQ. 1) THEN
!CCC        BKSTOP_PADJ = BKSTOP_PADJ + 1.
!CCC      ENDIF
          CNVGFLG = 0
          DO NET=1,NETWORK
            DO S=1,SNODES              ! LOOP OVER SUPPLY NODES
!CCC         IF (PSUP_CNVG(NET,S).EQ.0 .AND. QSUP_CNVG(NET,S).EQ.0) THEN
              IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = QSUP_WT * NODE_QSUP(NET,S) + &
                             (1.-QSUP_WT)* NODE_QSUPPREV(NET,S)
!CCC         ENDIF
            ENDDO
          ENDDO

          CALL NGSET_SUPPR
          IF (MODYR .GT. EHISYR) THEN
            CALL NGSTEO_BENCHWPR       ! SET SCALE FAC FOR ON/OFFSHORE WELLHEAD PRICE
          ENDIF

        ELSE
          CNVGFLG = 1
          WRITE(NGOERR,*) 'CONVERGED ON CYCLE= ',CYCLE, &
            '  ITR= ',CURITR,'  YEAR= ',MODYR, '     ! ATTN4'
        ENDIF
      ENDIF

      DO NET=1,NETWORK
        DO S=1,SNODES
          IF (SUPARRAY(S).EQ.1) THEN 
            N = TNODES + S
            NODE_ENDPR(NET,N) = NODE_PSUP(NET,S)
            NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

            NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S)
            NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S)
          ENDIF
        ENDDO
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  USE SUPPLY CURVES AND QTY TO SET WELLHEAD PRICES
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  FUNCTIONS USED:  NGSUP_PR
!
!  NOTES:   MAY WANT TO CHANGE PK/OP ALGORITHM
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      
      SUBROUTINE NGSET_SUPPR
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'
      include 'nghistinc'
      include 'ngtdminc'

      INTEGER*4  N,S,M,MX             ! COUNTERS
      INTEGER*4  NET                  ! NETWORK ID (1=PK, 2=OP)

      REAL*4 PKPR, OPPR               ! TEMP PK,OP SUP PRICES
      REAL*4 PQ                       ! SUM OF P*Q
      REAL*4 SPAVG(SNODES)            ! QTY WEIGHTED AVG OF PK & OP
      REAL*4 FSF                      ! FINE SCALING FACTOR
      REAL*4 SQSUP(NETWORK)           ! SEASONAL SUPPLY QTY
      REAL*4 SPSUP(NETWORK)           ! SEASONAL SUPPLY PRICE
      REAL*4 ANNSUP                   ! EQUIVALENT ANNUAL SUPPLY FROM PK,OP SUPPLY
      REAL*4 NGSUP_PR                 ! SUPPLY CURVE FUNCTION
      REAL*4 PKFAC                    ! ANNUAL TO PK SEASON CONVERSION
      REAL*4 OPFAC                    ! ANNUAL TO OP SEASON CONVERSION
      REAL*4 NGPRCLNG                 ! LNG SUPPLY CURVE FUNCTION
      REAL*4 QLAGTOT(NETWORK,NLNGCRV) ! LNG IMPORTS LAST YEAR, EAST AND WEST
      REAL*4 TOTQ(NETWORK,NLNGCRV)    ! IMPORT LEVELS IN EAST AND WEST (LAST YEAR, THIS YEAR)
      REAL*4 MEXLNGTOT                ! TOTAL MEXICO LNG IMPORTS ON GIVEN COAST 
      REAL*4 SH                       ! TEMPORARY HOLD SEASONAL MEXICO SHARE
      REAL*4 DUMMY                    ! DUMMY ARGUMENT WHEN NOT NEEDED BY FUNCTION

! ---------

      PKFAC = PKSHR_YR
      OPFAC = (1.-PKSHR_YR)

      DO S=1,SNODES                                            ! VARIABLE SUPPLY, 1-20,21
        PQ = 0.0
        RPSHIFT(S) = 0.0

        IF(SUPTYPE(S).NE.14 .AND. FIXLNGFLG) THEN 
          PSUP(S) = 0.0
          QSUP(S) = 0.0
        ENDIF
        
        IF (SUPARRAY(S).EQ.1) THEN
          QSUP(S) = NODE_QSUP(PKNET,S) + NODE_QSUP(OPNET,S)        
          N = S + TNODES          ! NODE ID
          IF(SUPTYPE(S).NE.14) THEN                             ! NON-LNG
            PSUP(S) = NGSUP_PR('Q',QSUP(S),S)        !*FUNCTION
            IF (MODYR .LE. EHISYR) THEN
              RPSHIFT(S) = HPSUP(S,MODYR) - PSUP(S)
              HIST_RPSHIFT(S,MODYR) = RPSHIFT(S)
              PSUP(S) = HPSUP(S,MODYR)
            ENDIF
            IF (S.EQ.18 .AND. (ZOGRESNG(18).LE.0.0 .OR. ZOGPRRNG(18).LE.0.0)) PSUP(S) = PSUP(8) - 0.15
            DO NET=1,NETWORK
              IF (NET .EQ. PKNET) THEN      ! PK
                ANNSUP = NODE_QSUP(NET,S) / PKFAC
              ELSE                        ! OP
                ANNSUP = NODE_QSUP(NET,S) / OPFAC
              ENDIF
              SQSUP(NET) = NODE_QSUP(NET,S)
              SPSUP(NET) = NGSUP_PR('Q',ANNSUP,S)    !*FUNCTION
              PQ = PQ + SPSUP(NET) * SQSUP(NET)
            ENDDO

            IF (QSUP(S) .GT. 0.) THEN
              SPAVG(S) = PQ / QSUP(S)
            ELSE
              SPAVG(S) = PSUP(S)
            ENDIF
            FSF = PSUP(S) / SPAVG(S)

            DO NET=1,NETWORK
              NODE_PSUP(NET,S) = SPSUP(NET) * FSF
            ENDDO
        
          ELSE                                                        ! LNG
            M = S - FSRGN(14) + 1
          
            IF (QSUP(S) .GT. 0.0) THEN
              PKSHR_PROD(S) = NODE_QSUP(PKNET,S)/QSUP(S)   !DEFINE LNG SHARE HERE?          
            ELSE
              PKSHR_PROD(S) = PKSHR_YR
            ENDIF
           
            IF (MODYR.LE.LHISYR) THEN
              DO NET=1,NETWORK
                NODE_PSUP(NET,S) = HPLNG(NET,4,MODYR)    ! GULF OF MEXICO PRICE
                PSUP(S) =  HPSUP(S,MODYR)
              ENDDO
            ELSE   ! forcast

 
              IF (LNGCRVOPT.EQ.6) THEN                           ! TOTAL N.AMER CURVE
                SQSUP = 0.0
                ANNSUP = 0.0

                DO NET=1,NETWORK
                  IF (NET.EQ.PKNET) THEN
                    SH = PKSHR_EMEX
                  ELSE
                    SH = 1.-PKSHR_EMEX
                  ENDIF
                  DO MX=1,NUMREG
                    SQSUP(NET) = SQSUP(NET) + MEXLNG(MX,MODYR) * SH
                    ANNSUP = ANNSUP + MEXLNG(MX,MODYR) * SH
                  ENDDO

                  DO N=FSRGN(14),FSRGN(14)+NSRGN(14)-1             ! ADD EAST AND WEST                  
                    SQSUP(NET) = SQSUP(NET) + NODE_QSUP(NET,N)     
                    ANNSUP = ANNSUP + NODE_QSUP(NET,N)
                  ENDDO
                ENDDO

! if using seasonal curves

                DO NET=1,NETWORK
                  NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,SQSUP(NET),'Q',DUMMY)    !*LNG FUNCTION (LAG NOT USED)
                  PQ = PQ + ( NODE_PSUP(NET,S) * SQSUP(NET) )
                ENDDO
                IF (ANNSUP .GT. 0.) THEN
                  SPAVG(S) = PQ / ANNSUP
                ELSE
                  SPAVG(S) = PSUP(9)
                ENDIF
                PSUP(S) = SPAVG(S)

! when have annual curves
!
!               PSUP(S) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY)        !*LNG FUNCTION (LAG NOT USED)
!               DO NET=1,NETWORK
!                 IF (NET .EQ. PKNET) THEN      ! PK
!                   ANNSUP = SQSUP(NET) / PKFAC
!                 ELSE                          ! OP
!                   ANNSUP = SQSUP(NET) / OPFAC
!                 ENDIF
!                 SPSUP(NET) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY)        !*LNG FUNCTION (LAG NOT USED)
!                 PQ = PQ + ( SPSUP(NET) * SQSUP(NET) )
!               ENDDO
!
!               IF ((SQSUP(PKNET) + SQSUP(OPNET)) .GT. 0.) THEN
!                 SPAVG(S) = PQ / (SQSUP(PKNET) + SQSUP(OPNET))
!               ELSE
!                 SPAVG(S) = PSUP(S)
!               ENDIF
!               FSF = PSUP(S) / SPAVG(S)
!
!               DO NET=1,NETWORK
!                 NODE_PSUP(NET,S) = SPSUP(NET) * FSF
!               ENDDO
            
              ELSE

                TOTQ(PKNET,M) = NODE_QSUP(PKNET,S)
                TOTQ(OPNET,M) = NODE_QSUP(OPNET,S)
                DO NET=1,NETWORK
                  IF (NET.EQ.PKNET) THEN
                    SH = PKSHR_EMEX
                  ELSE
                    SH = 1.-PKSHR_EMEX
                  ENDIF          
            
                  QLAGTOT(NET,M) = NODE_QSUPPREV(NET,S)
                  IF (M.EQ.1) THEN
                    MEXLNGTOT = (MEXLNG(2,MODYR) + MEXLNG(4,MODYR)) * SH
                  ELSEIF (M.EQ.2) THEN
                    MEXLNGTOT = (MEXLNG(1,MODYR) + MEXLNG(3,MODYR) + MEXLNG(5,MODYR)) * SH
                  ENDIF
                  QLAGTOT(NET,M) = QLAGTOT(NET,M) + MEXLNGTOT
                  TOTQ(NET,M) = TOTQ(NET,M) + MEXLNGTOT
            
                  NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,TOTQ(NET,M),'Q',QLAGTOT(NET,M))    !*LNG FUNCTION  
            
                  PQ = PQ + NODE_PSUP(NET,S) * TOTQ(NET,M)   !WITH ADJ FOR MEXICO, CORRECT?
                ENDDO
                IF ((TOTQ(PKNET,M)+TOTQ(OPNET,M)).GT.0.0) THEN 
                  PSUP(S)= PQ / (TOTQ(PKNET,M)+TOTQ(OPNET,M))
                ELSE
                  PSUP(S)= 1.0  ! NOT NECESSARILY BEST FALLBACK
                ENDIF
              ENDIF
            ENDIF  
          ENDIF
        ENDIF
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

!  PLACEHOLDER FOR SUPPLY CURVE FUNCTIONS
!  The new OGSM supply curves will be estimating equations
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY:  NGSET_SUPPR
!
!  NOTES:   -SUP CRV INCLUDES PROD FOR L&P
!           -INCREASE SUP QTY BY L&P % BEFORE USING SUP CRV
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

      REAL FUNCTION NGSUP_PR(INVAL,VALUE,IREG)
      IMPLICIT NONE
      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'
      include 'ngsteoinc'
      include 'ogglobal'

!  DETERMINES LEVEL OF PRODUCTION OR WELLHEAD PRICE GIVEN A PRICE OR
!  A LEVEL OF DESIRED PRODUCTION (RESPECTIVELY) FOR THE REQUESTED
!  NGTDM/OGSM REGION (ONSHORE, OFFSHORE, CANADA: 1-21)

      INTEGER*4 IREG            ! NGTDM/OGSM REGION (1-21)
      INTEGER*4 NREG            ! NGTDM REGION (1-12)
      INTEGER*4 IVREG           ! NGTDM/OGSM REGION for variable supply 
      INTEGER*4 I,J             ! COUNTER
      INTEGER*4 N,S               ! COUNTER
      INTEGER*4  NG_NREG        ! FUNCTION: MAPS SUP REG ID TO NG REG
      INTEGER*4  NG /2/                 ! temp: kevsup
      INTEGER*4 R
      INTEGER*4 ICNT            ! COUNTER

      REAL*4 QBASE              ! REFERENCE QUANTITY POINT
      REAL*4 PBASE              ! REFERENCE PRICE POINT
      REAL*4 XQBASE             ! RESERVES*(P/R)
      REAL*4 XPBASE             ! PRICE ASSOCIATED W/XQBASE
      REAL*4 AQBASE             ! QUANTITY AT PERCENT BELOW XQBASE
      REAL*4 APBASE             ! PRICE ASSOCIATED W/AQBASE
      REAL*4 BQBASE             ! QUANTITY AT PERCENT ABOVE XQBASE
      REAL*4 BPBASE             ! PRICE ASSOCIATED W/BPBASE
      REAL*4 CQBASE             ! QUANTITY AT PERCENT BELOW AQBASE
      REAL*4 CPBASE             ! PRICE ASSOCIATED W/CQBASE
      REAL*4 DQBASE             ! QUANTITY AT PERCENT ABOVE BQBASE
      REAL*4 DPBASE             ! PRICE ASSOCIATED W/DPBASE

      REAL*4 QVAR               ! TEMPORARY HOLDING ARRAY
      REAL*4 MIN_NA             ! MINIMUM ALLOWED NA PRODUCTION
      REAL*4 VALUE              ! INPUT PRICE OR QUANTITY
      REAL*4 FIXSUP             ! "FIXED" SUPPLY QUANTITY
      REAL*4 ELAS               ! SUPPLY CURVE "ELASTICITY"
      CHARACTER*1 INVAL         ! CHARACTER INDICATING IF THE INPUT
                                ! VALUE IS A PRICE OR QUANTITY
      REAL*4    QSHFT           ! SHIFT CN SUPPLY CURVE   (TEMP CODE)
      REAL*4 X                  ! HOLDS INTERMEDIATE VALUE
      REAL*4 PRCIN              ! INPUT PRICE ADJUSTED
      REAL*4 INITINP4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=P
      REAL*4 INITINQ4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=Q
      REAL*4 PRRLAG(20)   ! PREVIOUS YEAR'S P/R RATIO
      REAL*4 WPRLAG(20)   ! PREVIOUS YEAR'S WELLHEAD PRICE
      REAL*4 NEWVAL             ! P/R RATIO FOR OPTION 2
      REAL*4 PERCNT             ! PCT L&P AFTER SCALING
      REAL*4 REG_CNST(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST1(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST2(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST3(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST4(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST5(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 REG_CNST6(21)   ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC
      REAL*4 BETA1,BETA2,BETA3,TMPUS
      REAL*4 CNC,CNRHO,CNB1,CNPRLAG,TMPCAN,CNDL
      REAL*4 AVGWOP, AVGNGP, POST2000
      REAL*4 HDD, HDDLAG, L48_RA, L48_PRD, UGRSHR, REPRATE, ONCONVSHR, UGRRESSHR, UGRRESSHRLAG
      REAL*4 A1, B1, B2, B3, B4, B5, RHO
      REAL*4 Z1,Z2,Z3,Z4,Z5,Z6,Z7
      ! EPA ADDED VARIABLES
      REAL*4 U_PROD_CONV(17)
      REAL*4 U_PROD_TIGHT(17)
      REAL*4 U_PROD_SHALE(17)
      REAL*4 U_PROD_CBM(17)
      REAL*4 NG_REDUCT_NEW
      REAL*4 OIL_WELLS_TOT 
      REAL*4 CONV_WELLS_TOT
      REAL*4 TIGHT_WELLS_TOT
      REAL*4 SHALE_WELLS_TOT
      REAL*4 CBM_WELLS_TOT

!                      1        2       3        4        5        6       7        8        9        10
! EM4 TRACK -- keep here
      DATA REG_CNST /0.165,0.250,0.187,0.147,0.178,0.235,0.191,0.174,0.169,0.175, &         ! AEO2002: P0=f(PGASLAG,WOP)  change in ngtdm too
                     0.176,0.154,0.167,0.130,0.144,0.144,0.166,0.165,0.185,0.194,0.154/     !                             change in ngtdm too
      DATA REG_CNST1 /0.000000,1.22073,0.944568,0.644145,0.848594,1.22073,0.917775,0.839626,0.799027,0.818277,&   ! same form as AEO2002
                      0.837841,0.667143,0.760292,0.00000,0.63307,0.633293,0.842891,0.000000,0.873371,1.040223,&   ! parameters reestimated
                      0.427865/                                                                                   ! 9/07/02
      DATA REG_CNST2 /-1.00000,-2.60565,-1.90727,-2.63350,-2.82434,-2.96152,-2.69612,-2.17580,-1.78278,-2.08644, &  ! Kevin's supply curve
                      -2.08877,-2.57941,-2.01510,-1.00000,-1.70728,-2.62790,-2.28963,-1.00000,-1.58386,-2.97082, &  ! August 2002
                      -1.00000/
      DATA REG_CNST3 /0.00000,6.30131,5.11757,5.83751,6.42938,7.04815,6.50180,5.24769,4.73239,5.21296,&   ! P0=f(PR)
                      5.28422,6.06245,5.33154,0.00000,4.43217,6.04844,4.99544,0.00000,4.29734,6.19401,&   ! 7/06/05
                      5.51554/
      DATA REG_CNST4 /0.00000,6.12480,5.01729,5.85840,6.49504,6.84805,6.30017,5.25215,4.57664,5.01917,&   ! P0=f(PR)
                      5.12463,6.00357,4.87346,0.00000,4.34634,6.13117,4.88606,0.00000,4.19316,6.21324,&   ! 7/06/05
                      5.51554/
      DATA REG_CNST5 /0.00000,4.69550,3.56578,4.43286,5.08061,5.43386,4.87937,3.80729,3.11726,3.57019,&   ! P0=f(PR)
                      3.67787,4.58168,3.42322,0.00000,2.88471,4.71196,3.43140,0.00000,2.72364,4.78780,&   ! 7/06/05
                      4.08533/
      DATA REG_CNST6 /0.000000,-11.9200,-12.0374,-12.0671,-12.4173,-11.8249,-12.0920,-12.0038,-11.6418,-11.7450,&
                      -11.8647,-11.7754,-12.9530,0.000000,-12.1479,-11.8890,-12.1491,0.000000,-11.7204,-12.4344,&
                      -11.7829/

!------------------

      QSHFT= 0.0                ! temp code  (not used now)

!  SET REPLACEMENT RATE AND UNCONVENTIONAL GAS SHARE
      IF (MODYR.GT.EHISYR) THEN
        L48_PRD = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1)  &
                + oogqngrep(4,curiyr-1) + oogqngrep(6,curiyr-1))

        L48_RA = 0.
        DO R=1,20
          L48_RA = L48_RA + ZOGRADNGLAG1(r)
        ENDDO

        REPRATE = L48_RA / L48_PRD

        UGRSHR = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1))  &
               / L48_PRD
        onconvSHR = oogqngrep(4,curiyr-1) / L48_PRD
        UGRRESSHRLAG = (oOGNGRSV(1,curiyr-1)+oOGNGRSV(2,curiyr-1)+oOGNGRSV(3,curiyr-1))  &
                     / (oOGNGRSV(9,curiyr-1)) * 100.
        UGRRESSHR = (oOGNGRSV(1,curiyr)+oOGNGRSV(2,curiyr)+oOGNGRSV(3,curiyr))  &
                  / (oOGNGRSV(9,curiyr)) * 100.

        IF (MODYR.EQ.EHISYR+1) THEN
          HDDLAG = 4524                              ! HDD from 9/2009 STEO
          HDD = 4475.
    !     OEXSPEND(1,curiyr) = 1288.
    !     OEXSPEND(2,curiyr) = 67555752.
        ELSEIF (MODYR.EQ.EHISYR+2) THEN
          HDDLAG = HDD
          HDD = 4478.
    !     OEXSPEND(1,curiyr) = 1204.
    !     OEXSPEND(2,curiyr) = 59013208.
        ELSE
          HDDLAG = HDD
          HDD = 4237.
        ENDIF

      ELSE
        REPRATE = 0.
        UGRSHR = 0.
      ENDIF

!  SET VARIABLES WHICH DON'T CHANGE BASED ON VALUE COMING IN

!                     NREG = NG_NREG(IREG)          ! FUNCTION MAPPING SUP ID TO NG ID
      IVREG=VNODES(IREG)
      NREG = MAP_NG(IREG) 
      IF(IREG.EQ.SNODES-lSNODES-3) NREG=13
      PERCNT = PCTLP(NREG) * SCALE_LP(MODYR)

      IF (MODYR .LE. EHISYR) THEN
        XQBASE = QSUP(IREG) / (1.-PERCNT)  ! w/ L&P
      ELSE
        XQBASE = ZOGRESNG(IREG) * ZOGPRRNG(IREG)    ! w/ L*P
      ENDIF  

      ! EPA CODE MODIFICATION FOR RIA
      NG_REDUCT_NEW = 0    
  	OIL_WELLS_TOT  = 0
      CONV_WELLS_TOT = 0
      TIGHT_WELLS_TOT = 0
      SHALE_WELLS_TOT = 0
      CBM_WELLS_TOT = 0
  	  
      IF (IREG.LE.17 .and. CURIYR.GE.31) THEN
       
     
      ! NUMBER OF WELLS OF EACH TYPE
                          
      OIL_WELLS_TOT = oWELLSL48(2,1,1) + oWELLSL48(2,2,1) + oWELLSL48(2,3,1) &
                    + oWELLSL48(2,4,1) + oWELLSL48(2,5,1) + oWELLSL48(2,6,1) &
                    + oWELLSL48(2,1,2) + oWELLSL48(2,2,2) + oWELLSL48(2,3,2) &
                    + oWELLSL48(2,4,2) + oWELLSL48(2,5,2) + oWELLSL48(2,6,2) 
                   
      CONV_WELLS_TOT = oWELLSL48(2,1,3) + oWELLSL48(2,2,3) + oWELLSL48(2,3,3) &
                     + oWELLSL48(2,4,3) + oWELLSL48(2,5,3) + oWELLSL48(2,6,3) &
                     + oWELLSL48(2,1,4) + oWELLSL48(2,2,4) + oWELLSL48(2,3,4) &
                     + oWELLSL48(2,4,4) + oWELLSL48(2,5,4) + oWELLSL48(2,6,4) 
     
      TIGHT_WELLS_TOT = oWELLSL48(2,1,5) + oWELLSL48(2,2,5) + oWELLSL48(2,3,5) &
                      + oWELLSL48(2,4,5) + oWELLSL48(2,5,5) + oWELLSL48(2,6,5)
     
      SHALE_WELLS_TOT = oWELLSL48(2,1,6) + oWELLSL48(2,2,6) + oWELLSL48(2,3,6) &
                      + oWELLSL48(2,4,6) + oWELLSL48(2,5,6) + oWELLSL48(2,6,6)
 
      CBM_WELLS_TOT = oWELLSL48(2,1,7) + oWELLSL48(2,2,7) + oWELLSL48(2,3,7) &
                    + oWELLSL48(2,4,7) + oWELLSL48(2,5,7) + oWELLSL48(2,6,7)


      ! DISTRIBUTION OF PRODUCTION BY TYPE AND REGION, ESTIMATED BASED ON AEO2014 REFERENCE CASE MODEL IN 2020
	U_PROD_CONV(1)	=	0.0000
	U_PROD_CONV(2)	=	0.0455
	U_PROD_CONV(3)	=	0.0085
	U_PROD_CONV(4)	=	0.0702
	U_PROD_CONV(5)	=	0.0041
	U_PROD_CONV(6)	=	0.0000
	U_PROD_CONV(7)	=	0.0040
	U_PROD_CONV(8)	=	0.0446
	U_PROD_CONV(9)	=	0.3448
	U_PROD_CONV(10)	=	0.2801
	U_PROD_CONV(11)	=	0.0372
	U_PROD_CONV(12)	=	0.0776
	U_PROD_CONV(13)	=	0.0000
	U_PROD_CONV(14)	=	0.0000
	U_PROD_CONV(15)	=	0.0234
	U_PROD_CONV(16)	=	0.0463
	U_PROD_CONV(17)	=	0.0136
	U_PROD_TIGHT(1)	=	0.0000
	U_PROD_TIGHT(2)	=	0.0008
	U_PROD_TIGHT(3)	=	0.0055
	U_PROD_TIGHT(4)	=	0.0002
	U_PROD_TIGHT(5)	=	0.0025
	U_PROD_TIGHT(6)	=	0.0000
	U_PROD_TIGHT(7)	=	0.0043
	U_PROD_TIGHT(8)	=	0.0006
	U_PROD_TIGHT(9)	=	0.2017
	U_PROD_TIGHT(10)	=	0.1040
	U_PROD_TIGHT(11)	=	0.1209
	U_PROD_TIGHT(12)	=	0.4183
	U_PROD_TIGHT(13)	=	0.0000
	U_PROD_TIGHT(14)	=	0.0000
	U_PROD_TIGHT(15)	=	0.0163
	U_PROD_TIGHT(16)	=	0.1248
	U_PROD_TIGHT(17)	=	0.0000
	U_PROD_SHALE(1)	=	0.0000
	U_PROD_SHALE(2)	=	0.3385
	U_PROD_SHALE(3)	=	0.0077
	U_PROD_SHALE(4)	=	0.0000
	U_PROD_SHALE(5)	=	0.0000
	U_PROD_SHALE(6)	=	0.0246
	U_PROD_SHALE(7)	=	0.0011
	U_PROD_SHALE(8)	=	0.0000
	U_PROD_SHALE(9)	=	0.3616
	U_PROD_SHALE(10)	=	0.1470
	U_PROD_SHALE(11)	=	0.1163
	U_PROD_SHALE(12)	=	0.0031
	U_PROD_SHALE(13)	=	0.0000
	U_PROD_SHALE(14)	=	0.0000
	U_PROD_SHALE(15)	=	0.0001
	U_PROD_SHALE(16)	=	0.0000
	U_PROD_SHALE(17)	=	0.0000
	U_PROD_CBM(1)	=	0.0000
	U_PROD_CBM(2)	=	0.0000
	U_PROD_CBM(3)	=	0.0000
	U_PROD_CBM(4)	=	0.0004
	U_PROD_CBM(5)	=	0.0002
	U_PROD_CBM(6)	=	0.0181
	U_PROD_CBM(7)	=	0.0000
	U_PROD_CBM(8)	=	0.0494
	U_PROD_CBM(9)	=	0.0081
	U_PROD_CBM(10)	=	0.0242
	U_PROD_CBM(11)	=	0.0151
	U_PROD_CBM(12)	=	0.8543
	U_PROD_CBM(13)	=	0.0000
	U_PROD_CBM(14)	=	0.0000
	U_PROD_CBM(15)	=	0.0144
	U_PROD_CBM(16)	=	0.0160
	U_PROD_CBM(17)	=	0.0000


	! ESTIMATES AND DISTRIBUTES ESTIMATES OF CAPTURED GAS (IN BCF) ACROSS WELL TYPES AND REGION
   	NG_REDUCT_NEW =    (0.000019 * OIL_WELLS_TOT   * U_PROD_SHALE(IREG) & 
                       +  0.000136 * CONV_WELLS_TOT  * U_PROD_CONV(IREG)  &
                       +  0.000136 * TIGHT_WELLS_TOT * U_PROD_TIGHT(IREG) &
                       +  0.000136 * SHALE_WELLS_TOT * U_PROD_SHALE(IREG) &
                       +  0.000136 * CBM_WELLS_TOT   * U_PROD_CBM(IREG)             

      ! ADDS NATURAL GAS RECOVERED BE NEW SOURCES
                                       
      XQBASE = NG_REDUCT_NEW + XQBASE
   
      ENDIF     
     

      IF (MODYR.LE.EHISYR .OR. SUPCRV.EQ.1) THEN
        XPBASE = ZWPRLAG(IREG)
      ELSEIF (SUPCRV.EQ.10) THEN
        ICNT = 0
        XPBASE = 0.0
        DO J=1,IROLL
          IF (ZWPROLL(IREG,J).GT.0.001) THEN
            ICNT = ICNT + 1
            XPBASE = XPBASE + ZWPROLL(IREG,J)
          ENDIF
        ENDDO
        IF (ICNT.NE.0 .AND. MODYR.GT.LHISYR) THEN
          XPBASE = XPBASE / REAL(ICNT)
        ELSE
          XPBASE = ZWPRLAG(IREG)
        ENDIF
      ELSEIF (SUPCRV.EQ.3) THEN
        XPBASE = REG_CNST(IVREG) + (0.686*ZWPRLAG(IREG)) + (0.024*oIT_WOP(CURIYR,1)) - ZOGTAXPREM(IREG)
      ELSEIF (SUPCRV.EQ.4) THEN
        XPBASE = exp(-24.2580) * UGRRESSHR**1.62970 * oEXSPEND(1,curiyr-1)**0.066852 * HDD**2.22467 &
               * ZWPRLAG(IREG)**0.527302 * exp(-24.2580*(-0.527302)) * UGRRESSHRLAG**(-0.527302*1.62970) &
               * oEXSPEND(1,curiyr-2)**(-0.527302*0.066852) * HDD**(-0.527302*2.22467)
      ELSEIF (SUPCRV.EQ.5) THEN
        XPBASE = exp(-16.4735) * UGRRESSHR**1.16172 * oEXSPEND(1,curiyr-1)**0.072937 * HDD**1.49735 &
               * ZWPRLAG(IREG)**0.317304 * exp(-16.4735*(-0.317304)) * UGRRESSHRLAG**(-0.317304*1.16172) &
               * oEXSPEND(1,curiyr-2)**(-0.317304*0.072937) * HDD**(-0.317304*1.49735)
      ELSEIF (SUPCRV.EQ.6) THEN     ! AEO2010
        if (zogresng(ireg).gt.0.) THEN
          A1 = -10.6700   ! constant
          B4 = -0.014253  ! BOY res
          B1 = 0.633804   ! ugrresshr
          B2 = 0.190494   ! average drill cost
          B3 = 0.882912   ! HDD
          B5 = 0.279016   ! WOP
          RHO = 0.398350
          XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 &
               * ZOGRESNG(IREG)**(B4) &
               * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO  &
               * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &
               * (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &
               * ZOGRESNGLAG1(IREG)**(-RHO*B4) &
               * oIT_WOP(CURIYR-1,1)**(-RHO*B5) &
               * 1.00000
        ELSE
          XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))
        ENDIF
      ELSEIF (SUPCRV.EQ.7) THEN
        if (zogresng(ireg).gt.0.) THEN
          A1 = -0.298040  ! constant
          B4 = 0.         ! BOY res
          B1 = 0.         ! ugrresshr
          B2 = 0.403666   ! average cost per mcf
          B3 = 0.         ! HDD
          B5 = 0.311518   ! WOP
          RHO = 0.504134
          XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 &
               * ZOGRESNG(IREG)**(B4) &
               * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO  &
               * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &
               * (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &
               * ZOGRESNGLAG1(IREG)**(-RHO*B4) &
               * oIT_WOP(CURIYR-1,1)**(-RHO*B5) &
               * 1.01076
        ELSE
          XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))
        ENDIF
      ELSEIF (SUPCRV.EQ.8) THEN   
        if (zogresng(ireg).gt.0.) THEN
          A1 = -1.46449   ! constant
          B4 = 0.         ! BOY res
          B1 = 0.         ! ugrresshr
          B2 = 0.121770   ! average drill cost per reserve additions
          B3 = 0.         ! HDD
          B5 = 0.544238   ! WOP
          RHO = 0.626528
          XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 &
               * ZOGRESNG(IREG)**(B4) &
               * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO  &
               * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &
               * (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &
               * ZOGRESNGLAG1(IREG)**(-RHO*B4) &
               * oIT_WOP(CURIYR-1,1)**(-RHO*B5) &
               * 1.00303
        ELSE
          XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))
        ENDIF
      ELSEIF (SUPCRV.EQ.9) THEN
        if (zogresng(ireg).gt.0.) THEN
          A1 = 0.547003   ! constant
          B4 = 0.         ! BOY res
          B1 = 0.         ! ugrresshr
          B2 = 0.637656   ! average cost per mcf
          B3 = 0.         ! HDD
          B5 = 0.         ! WOP
          RHO = 0.379721
          XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 &
               * ZOGRESNG(IREG)**(B4) &
               * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO  &
               * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &
               * (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &
               * ZOGRESNGLAG1(IREG)**(-RHO*B4) &
               * oIT_WOP(CURIYR-1,1)**(-RHO*B5) &
               * 1.02188
        ELSE
          XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))
        ENDIF
      ELSEIF (SUPCRV.EQ.21) THEN
        IF (MODYR.LE.2006) THEN    ! steo?
          IF (SUPTYPE(IREG).LE.9) THEN
            XPBASE = 0.95*ZWPRLAG(IREG) - ZOGTAXPREM(IREG) - 0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))
          ELSE
            XPBASE = 0.66  + (0.75*ZWPRLAG(IREG)) - ZOGTAXPREM(IREG)
          ENDIF
        ELSE
          XPBASE = ZWPRLAG(IREG) - ZOGTAXPREM(IREG) - 0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))
          IF (SUPTYPE(IREG).GT.9) XPBASE = 0.36  + (0.85*ZWPRLAG(IREG)) - ZOGTAXPREM(IREG)
        ENDIF
        
      ELSEIF (SUPCRV.EQ.8) THEN
        XPBASE = exp(-2.88475) * UGRRESSHR**0.749417 * oIT_WOP(CURIYR,1)**0.325610  &
               * ZWPRLAG(IREG)**0.339752 * exp(-2.88475*(-0.339752)) * UGRRESSHRLAG**(-0.339752*0.749417) &
               * oIT_WOP(CURIYR-1,1)**(-0.339752*0.325610)
      ELSEIF (SUPCRV.EQ.9) THEN
!        IF (ZOGRESNG(IREG).GT.0.0) THEN
!          XPBASE = ZOGRESNG(IREG)**-0.047340 * oIT_WOP(CURIYR,1)**0.136745 *(UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432 &
!                 * ZWPRLAG(IREG)**0.277866 * ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340) &
!                 * oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745) * (UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432)
!
!          Z1 = ZOGRESNG(IREG)**-0.047340 
!          Z2 = oIT_WOP(CURIYR,1)**0.136745 
!          Z3 = (UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432 
!          Z4 = ZWPRLAG(IREG)**0.277866 
!          Z5 = ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340) 
!          Z6 = oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745) 
!          Z7 = (UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432)
!          XPBASE = Z1 * Z2 * Z3 * Z4 * Z5 * Z6 * Z7
!        ELSE
           XPBASE = ZWPRLAG(IREG)
!        ENDIF
      ENDIF
                                    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      IF (SUPCRV.NE.2) THEN       !!!!!!! supply curve type 1 !!!!!!

    
! ALL OTHER NG PRODUCTION

        FIXSUP = ZOGCCAPPRD(IREG) * (1.-PERCNT)
        AQBASE = XQBASE * (1. - PARM_SUPCRV3)
        BQBASE = XQBASE * (1. + PARM_SUPCRV3)
        APBASE = XPBASE * (1.- (PARM_SUPCRV3 /PARM_SUPELAS(3)))
        BPBASE = XPBASE * (1.+ (PARM_SUPCRV3 /PARM_SUPELAS(3)))

        IF (PARM_SUPCRV5 .EQ. 0.0) THEN         ! set 5-tier = 3-tier
          PARM_SUPELAS(1) = PARM_SUPELAS(2)
          PARM_SUPELAS(5) = PARM_SUPELAS(4)
        ENDIF

        CQBASE = AQBASE * (1. - PARM_SUPCRV5)
        DQBASE = BQBASE * (1. + PARM_SUPCRV5)
        CPBASE = APBASE * (1.- (PARM_SUPCRV5 /PARM_SUPELAS(2)))
        DPBASE = BPBASE * (1.+ (PARM_SUPCRV5 /PARM_SUPELAS(4)))

        MIN_NA = ZOGRESNG(IREG) * ZOGPRRNG(IREG) * &
                (1.-PERCNT) * PARM_MINPR      ! w/o L&P

!  THREE/FIVE TIER METHOD

        IF (INVAL.EQ.'P') THEN
          IF (VALUE .LE. CPBASE) THEN
            QBASE = CQBASE
            PBASE = CPBASE
            ELAS = PARM_SUPELAS(1)
          ELSE IF (VALUE .LE. APBASE) THEN
            QBASE = AQBASE
            PBASE = APBASE
            ELAS = PARM_SUPELAS(2)
          ELSE IF (VALUE .GE. DPBASE) THEN
            QBASE = DQBASE
            PBASE = DPBASE
            ELAS = PARM_SUPELAS(5)
          ELSE IF (VALUE .GE. BPBASE) THEN
            QBASE = BQBASE
            PBASE = BPBASE
            ELAS = PARM_SUPELAS(4)
          ELSE
            QBASE = XQBASE
            PBASE = XPBASE
            ELAS  = PARM_SUPELAS(3)
          END IF
          NGSUP_PR = (1.-PERCNT) * QBASE * &
              (1.+(ELAS*(VALUE-PBASE)/PBASE)) + QSHFT    ! temp code
!    *        (1.+(ELAS*(VALUE-PBASE)/PBASE))
          NGSUP_PR = AMAX1(NGSUP_PR,MIN_NA)   ! w/o L&P
          NGSUP_PR = FIXSUP + NGSUP_PR
          NGSUP_PR = AMAX1(NGSUP_PR,0.0)
        END IF

!  THREE TIER METHOD FOR QUANTITIES

        IF (INVAL.EQ.'Q') THEN
          IF (XQBASE.GT.0.0) THEN
!           QVAR = (VALUE - FIXSUP) / (1.-PERCNT)         ! w/ L&P
            QVAR = (VALUE - FIXSUP+QSHFT) / (1.-PERCNT)   ! temp code (QSHFT)
            IF (QVAR .LE. CQBASE) THEN
              QBASE = CQBASE
              PBASE = CPBASE
              ELAS = PARM_SUPELAS(1)
            ELSE IF (QVAR .LE. AQBASE) THEN
              QBASE = AQBASE
              PBASE = APBASE
              ELAS = PARM_SUPELAS(2)
            ELSE IF (QVAR .GE. DQBASE) THEN
              QBASE = DQBASE
              PBASE = DPBASE
              ELAS = PARM_SUPELAS(5)
            ELSE IF (QVAR .GE. BQBASE) THEN
              QBASE = BQBASE
              PBASE = BPBASE
              ELAS = PARM_SUPELAS(4)
            ELSE
              QBASE = XQBASE
              PBASE = XPBASE
              ELAS  = PARM_SUPELAS(3)
            END IF
            NGSUP_PR = PBASE * (((1./ELAS)*(QVAR-QBASE)/QBASE) + 1.)
          ELSE
            NGSUP_PR = XPBASE
          END IF
          IF (NGSUP_PR .LE. 0.0) THEN
            WRITE(NGUNIT,20) CURIYR,CURITR,IREG,NGSUP_PR,VALUE,XQBASE
            NGSUP_PR = 0.10   ! SET TO VERY LOW PRICE, BUT NOT NEGATIVE
          ENDIF
        END IF

                                        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ELSE IF(SUPCRV .EQ. 2) THEN       !!!!!!! supply curve type 2 !!!!!!
                                        ! NEW METHOD PER KEVIN FORBES AUGUST 2002

!                IF (IREG.EQ.21) THEN
        IF (SUPTYPE(IREG).GE.10) THEN
        IF (CURIYR.LE.1) THEN
          NGSUP_PR = ZWPRLAG(IREG)
        ELSE
! EM4 TRACK -- keep here
          CNC   = -3.70634
          CNRHO = 0.619602
          CNB1  = 0.325236
          CNDL  = (0.9184/0.7758)*1.2085  ! convert us87$ to cn92$
          CNPRLAG = oOGCNQPRD(NG,CURIYR-1) / oOGRESCAN(NG,CURIYR-1)
          TMPCAN = EXP(CNC*(1.-CNRHO))*(CNPRLAG/(1.-CNPRLAG))**CNRHO &
                * oOGCNPPRD(NG,CURIYR-1)**(-1.*CNRHO*CNB1)
          IF (INVAL.EQ.'Q') THEN
            NGSUP_PR = (( (VALUE/oOGRESCAN(NG,CURIYR)) / &
                       (TMPCAN * (1.- (VALUE/oOGRESCAN(NG,CURIYR)))) )**(1/CNB1))/CNDL
          ENDIF
          IF (INVAL.EQ.'P') THEN
            NGSUP_PR = oOGRESCAN(NG,CURIYR) &
                     * (TMPCAN * (VALUE*CNDL)**CNB1) / &
                       (1. + (TMPCAN * (VALUE*CNDL)**CNB1))
          ENDIF
        ENDIF
      ELSE

! EM4 TRACK -- keep here
        BETA1 = -0.297987
        BETA2 = -0.349741
        BETA3 = 0.150931
        IF (ZOGRESNGLAG1(IREG).GT.0.0.AND.ZOGRESNGLAG2(IREG).GT.0.0) THEN
          TMPUS = exp(REG_CNST2(IREG)) * (ZOGRADNGLAG1(IREG)/ZOGRESNGLAG1(IREG) + 1)**beta1  &
                * (ZOGRADNGLAG2(IREG)/ZOGRESNGLAG2(IREG) + 1)**beta2
        ENDIF
      

        IF (INVAL.EQ.'P') THEN
          IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN
            NGSUP_PR = 0.0
          ELSE
            NGSUP_PR = ZOGRESNG(IREG) &
                     * (TMPUS * VALUE**BETA3) / &
                       (1. + (TMPUS * VALUE**BETA3))
!CCC        WRITE(6,*) ' PROD=', NGSUP_PR
          ENDIF

!CCC      WRITE(6,*) 'PRICE SENT = ',VALUE
!CCC      WRITE(6,*) 'NGSUP_PR = ',NGSUP_PR,' RPSHIFT ',
!CCC *          RPSHIFT(IREG)
!CCC      WRITE(6,*) ' '
        ENDIF


        IF (INVAL.EQ.'Q') THEN
          IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN
            NGSUP_PR = WPRLAG(IREG)
          ELSE
            NGSUP_PR = ((VALUE / ZOGRESNG(IREG))  &
                     /  (TMPUS * (1 - VALUE/ZOGRESNG(IREG))))**(1/beta3)

            WRITE(6,*) 'REGION= ',IREG,'YEAR=',CURIYR+1989
            WRITE(6,*) 'TMPUS= ',TMPUS,' VALUE=',VALUE,'RES=',ZOGRESNG(IREG)
            WRITE(6,*) 'PRICE = ',NGSUP_PR
            WRITE(6,*) ' '
          ENDIF

        ENDIF
       ENDIF               ! temp: kevsup
      ENDIF

! TRACE

!     IF (IREG .EQ. SNODES) THEN         ! canadian supply
!       IF (INVAL.EQ.'Q') THEN
!         WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS
!         WRITE(NGOERR,15) AQBASE, XQBASE, BQBASE, QVAR, VALUE
!         WRITE(NGOERR,16) APBASE, XPBASE, BPBASE, NGSUP_PR
!       ELSE
!         WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS
!         WRITE(NGOERR,17) AQBASE, XQBASE, BQBASE, NGSUP_PR
!         WRITE(NGOERR,18) APBASE, XPBASE, BPBASE, VALUE
!       ENDIF
!     ENDIF
  14  FORMAT(1X,'NGSUP_PR: YR=',I4,' ITR=',I2,' INVAL=',A1, &
            ' FIXSUP=',F8.3,' PCTLP=',F8.3,' ELAS=',F8.4)
  15  FORMAT(1X,'NGSUP_PR: AQ=',F8.1,' XQ=',F8.1,' BQ=',F8.1, &
            '  QVAR=',F8.1,' VALUE=',F8.1)
  16  FORMAT(1X,'NGSUP_PR: AP=',F8.4,' XP=',F8.4,' BP=',F8.4, &
            ' SUPPR=',F8.4)
  17  FORMAT(1X,'NGSUP_PR: AQ=',F8.1,' XQ=',F8.1,' BQ=',F8.1, &
            ' SUPPR=',F8.1)
  18  FORMAT(1X,'NGSUP_PR: AP=',F8.4,' XP=',F8.4,' BP=',F8.4, &
            ' VALUE=',F8.4)

      IF (NGDBGITR(4,5)) THEN
        WRITE(NGUNIT,10) CURIYR,CURITR,IREG,INVAL,VALUE,NGSUP_PR
        WRITE(NGUNIT,11) XQBASE,ZOGRESNG(IREG), &
           ZOGPRRNG(IREG)
      END IF
  10  FORMAT(1X,'NGSUP_PR: YR=',I3,' ITR=',I3,' REG(1-21)=',I4, &
         ' P OR Q= ',A1,' VALUE=',F15.4,' NGSUP_PR=',F15.4)
  11  FORMAT(5X,'XQBASE=',F12.3,' ZOGRESNG=',F12.3,' ZOGPRRNG=', &
        F12.3)

  20  FORMAT(1X,'ATTN5 NGTDM, NGSUP_PRSUP_PR',I3,' ITR=',I3, &
        ' IREG(1-21)=',I4,' NGSUP_PR=',F10.3,' VALUE=',F10.1, &
        ' XQBASE=',F10.1)

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  USE FIXED AND VAR TARIFF INFO TO CALC ARC FEE
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  FUNCTIONS USED:  NGPIPE_VARTAR
!                   NGSTR_VARTAR
!
!  NOTES:  MAY WANT TO ADD PR ADJUSTMENT FOR PIPE FUEL
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_ARCFEE
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'

      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  STID          ! STORAGE NODE ID (1-14)
      INTEGER*4  XNET          ! END-USE(1,3) VS SHR(1,2) NETWORK INDICATOR

      REAL*4     NGSTR_VARTAR   ! FUNCTION (from ptm)
      REAL*4     NGPIPE_VARTAR  ! FUNCTION (from ptm)
      REAL*4     X1NGSTR_VARTAR ! FUNCTION (new)
      REAL*4     XNGSTR_VARTAR  !*FUNCTION (temp)
      REAL*4     XNGPIPE_VARTAR !*FUNCTION (temp)
      REAL*4     Q             ! FLOW ALONG ARC W/IN PK OR OP SEASON
! -------------

! TARIFF ON ALL PRIMARY ARCS

      DO NET=1,NETWORK
        DO A=1,NARCS
          SRC = ARC_2NODE(A,1)
          DEST= ARC_2NODE(A,2)
          Q = FLOW(NET,A)
          IF (SRC .LE. TNODES) THEN                           ! PIPELINE ARCS
            ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &
                                NGPIPE_VARTAR(NET,A,Q)             ! FUNCTION
            IF (NET .EQ. PKNET) THEN                             ! from ngptmX.f
 !!           ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &
 !!                               NGPIPE_VARTAR(NET,A,Q)           ! FUNCTION
              ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)           
            ELSE                                               ! from ngptmX.f
 !!           ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &  ! from ngptmX.f
 !!                               NGPIPE_VARTAR(NET,A,Q)
              ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)      ! from ngptmX.f
            ENDIF                                                                    
          ELSE IF (SRC .GT. (TNODES+SNODES)) THEN        ! STR ARCS
            IF (NET .EQ. PKNET) THEN
              STID = SRC - (TNODES+SNODES)
              ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &
                                  X1NGSTR_VARTAR(STID,Q)        ! FUNCTION
              ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &
                                  X1NGSTR_VARTAR(STID,Q)        ! FUNCTION
            ELSE
              ARC_ENDFEE(NET,A) = 0.0
              ARC_SHRFEE(NET,A) = 0.0
            ENDIF
          ELSE                                         ! SUPPLY ARCS
            ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)
            ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)
          ENDIF
        ENDDO
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  PLACEHOLDER FOR PIPELINE VARIABLE TARIFF FUNCTION
!
!  STATUS:  UNDER CONSTRUCTION  --  CHETHA WILL PROVIDE THIS ROUTINE
!
!  CALLED BY:  NGSET_ARCFEE
!
!  NOTES:   NEED TO TRANSLATE CAPACITY INTO PK (1/3) OR OP (2/3)
!            AND USE PKUTZ & OPUTZ TO GET PR FOR EFFECTIVE FLOW
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION XNGPIPE_VARTAR(XNET,A,SRC,DEST,Q)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  A           ! ARC ID
      INTEGER*4  SRC, DEST   ! SOURCE, DEST NODES ON ARC
      INTEGER*4  XNET        ! NETWORK SIGNAL
                ! mapping of network signal for var tar along pipe:
                !   1 = pk for use w/ sharing price calc
                !   2 = op for use w/ sharing price calc
                !   1 = pk for use w/ end-use price calc
                !   3 = op for use w/ end-use price calc

      REAL*4     Q              ! QUANTITY FLOWING ON NETWORK ARC
      REAL*4     QA             ! EQUIVALENT ANNUAL FLOW
! -------------

      IF (XNET .EQ. 1) THEN
          QA = Q / PKSHR_YR
        ELSE
          QA = Q / (1.-PKSHR_YR)
      ENDIF

! EM4 TRACK -- routine not called
      IF ((SRC.EQ.2) .AND. (DEST.EQ.1)) THEN
          XNGPIPE_VARTAR = (.023/413.)*QA
      ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.2)) THEN
          XNGPIPE_VARTAR = (.089/780.)*QA
      ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.5)) THEN
          XNGPIPE_VARTAR = (.133/890.)*QA
      ELSE IF ((SRC.EQ.4) .AND. (DEST.EQ.3)) THEN
          XNGPIPE_VARTAR = (.099/3106.)*QA
      ELSE IF ((SRC.EQ.5) .AND. (DEST.EQ.2)) THEN
          XNGPIPE_VARTAR = (.106/2496.)*QA
      ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.3)) THEN
          XNGPIPE_VARTAR = (.100/3525.)*QA
      ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.5)) THEN
          XNGPIPE_VARTAR = (.125/2664.)*QA
      ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.10)) THEN
          XNGPIPE_VARTAR = (.081/ 378.)*QA
      ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.4)) THEN
          XNGPIPE_VARTAR = (.145/2966.)*QA
      ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.6)) THEN
          XNGPIPE_VARTAR = (.108/7207.)*QA
      ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.4)) THEN
          XNGPIPE_VARTAR = (.074/ 950.)*QA
      ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.7)) THEN
          XNGPIPE_VARTAR = (.080/  73.)*QA
      ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.9)) THEN
          XNGPIPE_VARTAR = (.020/ 621.)*QA
      ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.11)) THEN
          XNGPIPE_VARTAR = (.049/ 213.)*QA
      ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.12)) THEN
          XNGPIPE_VARTAR = (.063/1353.)*QA
      ELSE IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN
          XNGPIPE_VARTAR = (.023/ 413.)*QA
      ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.7)) THEN
          XNGPIPE_VARTAR = (.035/1110.)*QA
      ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.12)) THEN
          XNGPIPE_VARTAR = (.063/1353.)*QA
!     ELSE IF ((SRC.EQ.13) .AND. (DEST.EQ.1)) THEN
!         XNGPIPE_VARTAR = (.007/  24.)*QA
!     ELSE IF ((SRC.EQ.14) .AND. (DEST.EQ.2)) THEN
!         XNGPIPE_VARTAR = (.007/ 150.)*QA
!     ELSE IF ((SRC.EQ.16) .AND. (DEST.EQ.4)) THEN
!         XNGPIPE_VARTAR = (.047/ 789.)*QA
!     ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.4)) THEN
!         XNGPIPE_VARTAR = (.059/ 993.)*QA
!     ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.8)) THEN
!         XNGPIPE_VARTAR = (.059/ 993.)*QA
!     ELSE IF ((SRC.EQ.18) .AND. (DEST.EQ.9)) THEN
!         XNGPIPE_VARTAR = (.310/ 301.)*QA
!     ELSE IF ((SRC.EQ.19) .AND. (DEST.EQ.9)) THEN
!         XNGPIPE_VARTAR = (.310/ 301.)*QA
!     ELSE IF ((SRC.EQ.20) .AND. (DEST.EQ.7)) THEN
!         XNGPIPE_VARTAR = (.142/  16.)*QA
!     ELSE IF ((SRC.EQ.21) .AND. (DEST.EQ.11)) THEN
!         XNGPIPE_VARTAR = (.142/   1.)*QA
!     ELSE IF ((SRC.EQ.22) .AND. (DEST.EQ.12)) THEN
!         XNGPIPE_VARTAR = (0.)*QA

!     IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN
!       IF (Q .LE. 413.) THEN
!           XNGPIPE_VARTAR = .0000557*Q
!         ELSEIF (Q .LE. 433.) THEN
!           XNGPIPE_VARTAR = .0003*Q
!         ELSEIF (Q .LE. 825.) THEN
!           XNGPIPE_VARTAR = .0004796*Q
!         ELSEIF (Q .LE. 1238.) THEN
!           XNGPIPE_VARTAR = .00103*Q
!         ELSE
!           XNGPIPE_VARTAR = .00189*Q
!       ENDIF

      ELSE
        XNGPIPE_VARTAR = .001
      ENDIF

!     XNGPIPE_VARTAR = .001     ! temp code

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  PLACEHOLDER FOR STORAGE VARIABLE TARIFF FUNCTION
!
!  STATUS:  UNDER CONSTRUCTION  --  CHETHA WILL PROVIDE THIS ROUTINE
!
!  CALLED BY:  NGSET_ARCFEE
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION XNGSTR_VARTAR(S,Q)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  S              ! STORAGE ID (1-14)

      REAL*4     Q              ! QUANTITY FLOWING ON NETWORK ARC
! -------------

      XNGSTR_VARTAR = .001

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  MOVEMENT UP NETWORKS TO SET ARC AND NODE PRICES
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  QUESTIONS: HOW DO WE ADJUST PR FOR IMPACT FROM BKSTOP?
!             --PERCENTAGE INCREASE IN NODE_SHRPR & NODE_ENDPR ??
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
      SUBROUTINE NGUP_TREE(NET)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
!CCC  INTEGER*4  SHR_PRFLG     ! FLAG INDICATING SHR_PR HAS BEEN INIT
      INTEGER*4  I,J,K,N       ! GENERIC INDICES

      REAL*4     SHR_PR        ! MARGINAL PR AT NODE ($/MCF)
      REAL*4     PQ, Q         ! HOLDS TOT USED TO CALC AVG PR
      REAL*4     ARCPQ,ARCQ    ! HOLDS TOT USED TO ADJ PR FOR PFUEL LOSS
      REAL*4     TARCPQ,TARCQ  ! HOLDS TOT USED TO AVG PR
      REAL*4     HBSPOT(NETWORK,DNODES,FSPOTYR:LHISYR)   ! BENCHMARK FACTOR FOR REGIONAL SPOT PRICES HISTORICAL
      REAL*4     BSPOT(NETWORK,DNODES)                   ! BENCHMARK FACTOR FOR REGIONAL SPOT PRICES FORECAST
     
      LOGICAL    FIRST         ! FIRST TIME CALLED IN FIRST FORECAST YEAR
      DATA FIRST/.TRUE./

! -------------

      DO L=NPROC,1,-1          ! MOVE UP TREE
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(NET,DEST,1)
        ARC_2 = ARC_LOOP(NET,DEST,2)

        SHR_PR = 0.0
!CCC    SHR_PRFLG = 0
        PQ = 0.0
        Q = 0.0
        TARCPQ = 0.0
        TARCQ = 0.0

        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
! BEFORE PIPEFUEL LOSS ADJ
          ARC_ENDPR(NET,A) = NODE_ENDPR(NET,SRC) + ARC_ENDFEE(NET,A)
          ARCPQ = ARC_ENDPR(NET,A) * FLOW(NET,A)
          ARCQ  = FLOW(NET,A) - ARC_PFUEL(NET,A)
! AFTER PIPEFUEL LOSS ADJ
          IF (ARCQ .GT. 0.) THEN
            ARC_ENDPR(NET,A) = ARCPQ / ARCQ     ! AFTER PFUEL LOSS ADJ
          ENDIF
          PQ = PQ + ARCPQ
          Q  = Q  + ARCQ

! BEFORE PIPEFUEL LOSS ADJ
          ARC_SHRPR(NET,A) = NODE_SHRPR(NET,SRC) + ARC_SHRFEE(NET,A)
          ARCPQ = ARC_SHRPR(NET,A) * FLOW(NET,A)
          ARCQ  = FLOW(NET,A) - ARC_PFUEL(NET,A)
! AFTER PIPEFUEL LOSS ADJ
          IF (ARCQ .GT. 0.) THEN
            ARC_SHRPR(NET,A) = ARCPQ / ARCQ     ! AFTER PFUEL LOSS ADJ
          ENDIF
                   ! THE FOLLOWING REPLACES THE SUCCEEDING LINES OF CODE
!         IF (FLOW_REM(NET,A) .GT. 0.0) THEN
            TARCPQ = TARCPQ + ARCPQ
            TARCQ  = TARCQ  + ARCQ
!         ENDIF
!CCC      IF (FLOW_REM(NET,A) .GT. 0.0) THEN
!CCC        IF (SHR_PRFLG .EQ. 0) THEN
!CCC            SHR_PR = ARC_SHRPR(NET,A)
!CCC            SHR_PRFLG = 1
!CCC          ELSE
!CCC            SHR_PR = AMIN1(SHR_PR, ARC_SHRPR(NET,A))
!CCC        ENDIF
!CCC      ENDIF
        ENDDO

                    ! THE FOLLOWING 5 LINES ADDED W/ ABOVE ADDITION
        IF (TARCQ .GT. 0.0) THEN
            SHR_PR = TARCPQ / TARCQ
          ELSE
            SHR_PR = ARC_SHRPR(NET,ARC_1)       ! CYCLE=1
            DO A=ARC_1,ARC_2
              SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A))
            ENDDO
        ENDIF

!CCC    IF (SHR_PRFLG .EQ. 0) THEN      ! EXPANSION ON ALL ARCS
!CCC      SHR_PR = ARC_SHRPR(NET,ARC_1)
!CCC      DO A=ARC_1,ARC_2
!CCC        SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A))
!CCC      ENDDO
!CCC    ENDIF

        NODE_SHRPR(NET,DEST) = SHR_PR
        IF (Q .GT. 0.0) THEN
            NODE_ENDPR(NET,DEST) = PQ / Q
          ELSE
            NODE_ENDPR(NET,DEST) = SHR_PR
        ENDIF

! ADJUST NODE PRICE FOR PR IMPACT FROM INTRAREG PFUEL

        IF (INTRA_PFUEL(NET,DEST).GT.0.0) THEN
          IF ((NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST)) .GT. 0.0) THEN 
            NODE_SHRPR(NET,DEST)=(NODE_SHRPR(NET,DEST)*NODE_DMD(NET,DEST)) / &
                                 (NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST))
            NODE_ENDPR(NET,DEST)=(NODE_ENDPR(NET,DEST)*NODE_DMD(NET,DEST)) / &
                                 (NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST))
          ELSE
            write(6,'(A,I2,A,I2)') " Preventing infinity caused by NODE_DMD = INTRA_PFUEL at NET=",NET," DEST=",DEST
          ENDIF
        ENDIF

                                        ! BKSTOP PRICE PENALTY
        IF (BKSTOP(NET,DEST) .GT. 0.) THEN
          IF (RBKSTOP_FLG(NET,DEST) .EQ. 0) THEN
            BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5
          ENDIF
          RBKSTOP_PADJ(NET,DEST) = RBKSTOP_PADJ(NET,DEST) + &
                                    BKSTOP_PADJ(NET,DEST)
          RBKSTOP_FLG(NET,DEST) = 1
        ELSE
!         IF (RBKSTOP_FLG(NET,DEST) .EQ. 1) THEN
!           BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5
!         ENDIF
!         RBKSTOP_PADJ(NET,DEST) = AMAX1(0.0,
!    *        (RBKSTOP_PADJ(NET,DEST) - BKSTOP_PADJ(NET,DEST)))
          RBKSTOP_FLG(NET,DEST) = 0
        ENDIF

!       RBKSTOP_PADJ(NET,DEST) = 0.0     ! temp code

        NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + &
                               RBKSTOP_PADJ(NET,DEST)
!       NODE_ENDPR(NET,DEST) = NODE_ENDPR(NET,DEST) +
!    +                         RBKSTOP_PADJ(NET,DEST)

!  BENCHMARK TO HISTORICAL SPOT PRICES

        IF (DEST.LE.DNODES .AND. MODYR.GE.FSPOTYR) THEN
          IF (MODYR.LE.LHISYR) THEN
            HBSPOT(NET,DEST,MODYR) = HNSPOT(NET,DEST,MODYR) - NODE_SHRPR(NET,DEST)
            NODE_SHRPR(NET,DEST) = HNSPOT(NET,DEST,MODYR)
          ELSE
            IF (FIRST) THEN
              BSPOT = 0.0
              DO N=1,NETWORK
                DO J=1,DNODES
                  DO K=FSPOTYR,LHISYR
                    BSPOT(N,J) = BSPOT(N,J) + HBSPOT(N,J,K)
                  ENDDO
                  BSPOT(N,J) = BSPOT(N,J) / REAL(LHISYR-FSPOTYR+1)
                ENDDO
              ENDDO
              FIRST = .FALSE.
            ENDIF
            NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + BSPOT(NET,DEST)
          ENDIF
        ENDIF         
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET STORAGE PRICES FOR USE IN PK, BASED ON OP RESULTS
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_STORPR
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC

! -------------

      DO L=1,NPROC                ! LOOP OVER TRANSFER NODES
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)

        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          IF (SRC .GT. (TNODES+SNODES)) THEN
            NODE_SHRPR(PKNET,SRC) = NODE_SHRPR(OPNET,DEST)
            NODE_ENDPR(PKNET,SRC) = NODE_ENDPR(OPNET,DEST)
          ENDIF
        ENDDO
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET INTRAREGIONAL FLOWS, CAPACITIES, AND TARIFFS
!
!  STATUS:
!
!  CALLED BY:  NGTDM_ITM
!
!  QUESTIONS:
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_INTRAFLO
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ngptmitm'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A             ! COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)

      REAL*4     FAC(DNODES)   ! SEASONAL SHARE FACTOR
      REAL*4     PKNETDMD      ! PK NET NODE DMD (W/O PIPEFUEL)
      REAL*4     OPNETDMD      ! OP NET NODE DMD (W/O PIPEFUEL)
      REAL*4     NGPIPE_VARTAR ! PTM FUNCTION TO SET PIPE TARIFF
      REAL*4     TEMP          ! TEMP HOLD INTRAREG VARTAR
! --------

! DEFINE INTRAREGIONAL FLOWS, FLOW FACTOR, AND TARIFFS
!    FLO_FAC = INTRA_FLO / NODE_DMD(W/O PF)

      DO DEST=1,DNODES
        DO NET=1,NETWORK
          IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN
            IF (NET .EQ. PKNET) THEN                  ! PEAK SEASON
              PKNETDMD = NODE_DMD(PKNET,DEST)-PFUEL(PKNET,DEST)
              OPNETDMD = NODE_DMD(OPNET,DEST)-PFUEL(OPNET,DEST)
              FAC(DEST) = PKNETDMD / (PKNETDMD + OPNETDMD)
             ELSE                                     ! OFFPEAK SEASON
              FAC(DEST) = 1. - FAC(DEST)
            ENDIF
            A = SNODE_2ARC(DEST,DEST)
            INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR)
            HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / &
                  (NODE_DMD(NET,DEST) - PFUEL(NET,DEST))
!          write(69,*)'intra',modyr,dest,net,INTRA_FLO(NET,DEST,MODYR),SAFLOW(A,MODYR),NODE_DMD(NET,DEST),PFUEL(NET,DEST)
          ELSE
            A = SNODE_2ARC(DEST,DEST)
            INTRA_FLO(NET,DEST,MODYR) = FLO_FAC(NET,DEST) * &
                  (NODE_DMD(NET,DEST) - PFUEL(NET,DEST))
            IF (NET .EQ. PKNET) THEN
              SAFLOW(A,MODYR) = INTRA_FLO(PKNET,DEST,MODYR)
             ELSE
              SAFLOW(A,MODYR) = SAFLOW(A,MODYR) + &
                                INTRA_FLO(NET,DEST,MODYR)
            ENDIF
          ENDIF

!CCC      TEMP = INTRAREG_TAR(NET,DEST) - INTRAREG_FIXTAR(NET,DEST)
!CCC      WRITE(4,1000) MODYR,NET,DEST,INTRAREG_FIXTAR(NET,DEST),
!CCC *      TEMP,INTRAREG_TAR(NET,DEST),INTRA_FLO(NET,DEST,MODYR)
!1000          FORMAT(' INTRA ',I4,2I3,3F6.3,F10.2)
        ENDDO
      ENDDO

      IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN
        CALL HNGSET_CGPR
      ELSE
        DO DEST=1,DNODES
          DO NET=1,NETWORK
            INTRAREG_TAR(NET,DEST) = INTRAREG_FIXTAR(NET,DEST) + &
               NGPIPE_VARTAR(NET,NARCS+DEST,INTRA_FLO(NET,DEST,MODYR))  ! PTM function
          ENDDO
        ENDDO
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET END-USE SECTOR PRICES BASED ON AVERAGE NODE PRICES
!  AND HUB MARKUPS (PROVIDED BY DTM)
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  QUESTIONS: WHAT ABOUT LOSSES ALONG DISTRIBUTOR ARCS?
!             DO NEW QUANTITIES NEED TO BE DEFINED HERE?
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_SECPR
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngdtminc'
      include 'ngcdmdinc'
      include 'ngptmitm'
      include 'ngsteoinc'
      include 'ogglobal'

      INTEGER*4  N             ! DEMAND NODES
      INTEGER*4  CENREG        ! CENSUS DIVISION
      INTEGER*4  J             ! COUNTER
      INTEGER*4  NET           ! REPRESENTS PK/OP NETWORKS
      INTEGER*4  SEC           ! SECTOR ID

      REAL*4     PQ            ! TOTAL (NODE PR * DMD QTY)
      REAL*4     Q             ! TOTAL DMD QTY
      REAL*4     PQ_F(DNODES)  ! PR * QTY FOR FIRM UTIL
      REAL*4     PQ_I(DNODES)  ! PR * QTY FOR INTRP UTIL
      REAL*4     Q_F(DNODES)   ! QTY FOR FIRM UTIL
      REAL*4     Q_I(DNODES)   ! QTY FOR INTRP UTIL
      REAL*4     NGSET_INTRATAR! FUNCTION TO SET INTRAREG TARIFFS

! -------------

! SET SEASONAL F/I END-USE PRICES FOR NONUTILITY SECTORS

      DO N=1,DNODES               ! LOOP OVER END-USE DEMAND NODES
        DO NET=1,NETWORK          ! LOOP OVER PK/OP NETWORKS

          CGPR(NET,N) = NODE_ENDPR(NET,N) + INTRAREG_TAR(NET,N) + &
                        INTRAST_TAR(N) + CGBENCH(NET,N)
          DO SEC=1,DSEC-1         ! NONUTILITY (F TRANS WILL BE REPLACED)
!           NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N) +
!    *                           SCALE_FPR(MODYR)
!           NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N) +
!    *                           SCALE_IPR(MODYR)
            NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N)
            NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N)
          ENDDO
                                  ! FLEET AND PERSONAL VEHICLES
          SEC=4
!         NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N) +
!    *                          SCALE_FPR(MODYR)
!         NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N) +
!    *                          SCALE_FPR(MODYR)
          NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N)
          NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N)
          IF (OPTELS.EQ.0) THEN
            NGPR_TRFV_SL(NET,N) = CGPR(NET,N) + DTAR_TRFV_SL(NET,N)
            NGPR_TRPV_SL(NET,N) = CGPR(NET,N) + DTAR_TRPV_SL(NET,N)
          ELSE
            NGPR_TRFV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRFV_SL(NET,N)
            NGPR_TRPV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRPV_SL(NET,N)
          ENDIF

!  assume ship prices same as for vehicles except no state taxes
!  assume rail prices same as for vehicles except no taxes and discount on LNG

          NGPR_TRLN_SR(NET,N) = NGPR_TRFV_SL(NET,N) - TRAIN_DISC - ((STAXL(N)+FTAXL) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))
          NGPR_TRCN_SR(NET,N) = NGPR_TRFV_SF(NET,N) - ((STAX(N)+FTAX) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))
          NGPR_TRLN_SS(NET,N) = NGPR_TRFV_SL(NET,N) - (STAXL(N) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))
          NGPR_TRCN_SS(NET,N) = NGPR_TRFV_SF(NET,N) - (STAX(N) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))
 
          NGPR_SF(NET,SEC,N) = &
           ( (NGPR_TRFV_SF(NET,N) * BASQ_TRFV_SF(NET,N)) + &
             (NGPR_TRPV_SF(NET,N) * BASQ_TRPV_SF(NET,N)) + &
             (NGPR_TRFV_SL(NET,N) * BASQ_TRFV_SL(NET,N)) + &
             (NGPR_TRPV_SL(NET,N) * BASQ_TRPV_SL(NET,N)) + &   
             (NGPR_TRLN_SR(NET,N) * BASQ_TRLN_SR(NET,N)) + &
             (NGPR_TRCN_SR(NET,N) * BASQ_TRCN_SR(NET,N)) + &
             (NGPR_TRLN_SS(NET,N) * BASQ_TRLN_SS(NET,N)) + &
             (NGPR_TRCN_SS(NET,N) * BASQ_TRCN_SS(NET,N)) ) / &
             (BASQ_TRFV_SF(NET,N) + BASQ_TRPV_SF(NET,N) + &
              BASQ_TRFV_SL(NET,N) + BASQ_TRPV_SL(NET,N) + & 
              BASQ_TRLN_SR(NET,N) + BASQ_TRCN_SR(NET,N) + &
              BASQ_TRLN_SS(NET,N) + BASQ_TRCN_SS(NET,N))
        ENDDO
      ENDDO

! SET SEASONAL F/I END-USE PRICES FOR NONUTILITY SECTORS

      DO J=1,NNGEM-1              ! UTILITY SUBREGIONS 1-16
        N = EMMSUB_NG(J)          ! NGTDM REGION 1-12
        DO NET=1,NETWORK
!         NGUPR_SF(NET,J) = CGPR(NET,N) + UDTAR_SF(NET,J) +
!    *                      SCALE_FPR(MODYR)
!         NGUPR_SI(NET,J) = CGPR(NET,N) + UDTAR_SI(NET,J) +
!    *                      SCALE_IPR(MODYR)
          IF (OPTELS.EQ.0) THEN
            NGUPR_SF(NET,J) = CGPR(NET,N) + UDTAR_SF(NET,J)
            NGUPR_SI(NET,J) = CGPR(NET,N) + UDTAR_SI(NET,J)
          ELSE
            NGUPR_SF(NET,J) = NODE_SHRPR(NET,N) + UDTAR_SF(NET,J)
            NGUPR_SI(NET,J) = NODE_SHRPR(NET,N) + UDTAR_SI(NET,J)
          ENDIF  

! temp set f * i to average
          IF ((BASUQTY_SF(NET,J)+BASUQTY_SI(NET,J)) .GT. 0.0000001) THEN
            NGUPR_SF(NET,J) = ((NGUPR_SF(NET,J)*BASUQTY_SF(NET,J)) + &
                               (NGUPR_SI(NET,J)*BASUQTY_SI(NET,J))) / &
                         (BASUQTY_SF(NET,J) + BASUQTY_SI(NET,J))
          ELSE
            NGUPR_SF(NET,J) = 2.0
          ENDIF
          NGUPR_SI(NET,J) = NGUPR_SF(NET,J)
        ENDDO
      ENDDO

!  SET STEO SCALE FACTOR AND ADJUST END-USE PRICES

      IF (MODYR .GT. EHISYR) THEN
        CALL NGSTEO_BENCHENDPR

        DO NET=1,NETWORK
          DO N=1,DNODES
            DO SEC=1,DSEC-1
              NGPR_SF(NET,SEC,N) = NGPR_SF(NET,SEC,N) + SCALE_FPR(SEC,MODYR)
              NGPR_SI(NET,SEC,N) = NGPR_SI(NET,SEC,N) + SCALE_IPR(SEC,MODYR)
            ENDDO

            SEC=4                      ! TRANS
            NGPR_TRFV_SF(NET,N) = NGPR_TRFV_SF(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRPV_SF(NET,N) = NGPR_TRPV_SF(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRFV_SL(NET,N) = NGPR_TRFV_SL(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRPV_SL(NET,N) = NGPR_TRPV_SL(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRLN_SR(NET,N) = NGPR_TRLN_SR(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRCN_SR(NET,N) = NGPR_TRCN_SR(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRLN_SS(NET,N) = NGPR_TRLN_SS(NET,N) + SCALE_FPR(SEC,MODYR)
            NGPR_TRCN_SS(NET,N) = NGPR_TRCN_SS(NET,N) + SCALE_FPR(SEC,MODYR)
          ENDDO

          SEC = 5                      ! UTILITY
          DO J=1,NNGEM-1
            NGUPR_SF(NET,J) = NGUPR_SF(NET,J) + SCALE_FPR(SEC,MODYR)
            NGUPR_SI(NET,J) = NGUPR_SI(NET,J) + SCALE_IPR(SEC,MODYR)
          ENDDO
        ENDDO
      ENDIF

! SET ANNUAL F/I END-USE PRICES FOR NONUTILITY SECTORS

      DO N=1,DNODES               ! LOOP OVER END-USE DEMAND NODES
        DO SEC=1,DSEC-1           ! NONUTILITY (F TRANS WILL BE REPLACED)
          NGPR_F(SEC,N) = PKSHR_DMD(SEC,N) * NGPR_SF(PKNET,SEC,N) + &
                      (1.-PKSHR_DMD(SEC,N))* NGPR_SF(OPNET,SEC,N)

          NGPR_I(SEC,N) = PKSHR_DMD(SEC,N) * NGPR_SI(PKNET,SEC,N) + &
                      (1.-PKSHR_DMD(SEC,N))* NGPR_SI(OPNET,SEC,N)
        ENDDO

        SEC=4                     ! FLEET AND PERSONAL VEHICLES
        NGPR_TRFV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SF(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRFV_SF(OPNET,N)
        NGPR_TRPV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SF(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRPV_SF(OPNET,N)
        NGPR_TRFV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SL(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRFV_SL(OPNET,N)
        NGPR_TRPV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SL(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRPV_SL(OPNET,N)
        NGPR_TRLN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SR(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRLN_SR(OPNET,N)
        NGPR_TRCN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SR(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRCN_SR(OPNET,N)
        NGPR_TRLN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SS(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRLN_SS(OPNET,N)
        NGPR_TRCN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SS(PKNET,N) + &
                     (1.-PKSHR_DMD(SEC,N))* NGPR_TRCN_SS(OPNET,N)

! COMPARE CNG PRICE FOR PERSONNEL VEHICLES TO COMMERCIAL MOTOR GASOLINE PRICE

        CENREG = NG_CENMAP(N)     ! CENSUS DIVISION
   !    NGPR_TRPV_F(N) = AMAX1(NGPR_TRPV_F(N)+(oJNGTR(CURIYR)*oCFNGN(CURIYR)), &
   !        ((oPMGTR(CENREG,CURIYR)+oJMGTR(CURIYR))*oCFNGN(CURIYR))**PERMG) - &
   !        oJNGTR(CURIYR)*oCFNGN(CURIYR)
        SEC=4                     ! REPLACE F TRANS
        NGPR_F(SEC,N) = ( (NGPR_TRFV_F(N) * BASQ_TRFV_F(N)) + &
                          (NGPR_TRPV_F(N) * BASQ_TRPV_F(N)) + &
                          (NGPR_TRFV_L(N) * BASQ_TRFV_L(N)) + &
                          (NGPR_TRPV_L(N) * BASQ_TRPV_L(N)) + &
                          (NGPR_TRLN_R(N) * BASQ_TRLN_R(N)) + &
                          (NGPR_TRCN_R(N) * BASQ_TRCN_R(N)) + &
                          (NGPR_TRLN_S(N) * BASQ_TRLN_S(N)) + &
                          (NGPR_TRCN_S(N) * BASQ_TRCN_S(N)) ) / &
                          (BASQ_TRFV_F(N) + BASQ_TRPV_F(N)  + &
                           BASQ_TRFV_L(N) + BASQ_TRPV_L(N)  + &
                           BASQ_TRLN_R(N) + BASQ_TRCN_R(N)  + &
                           BASQ_TRLN_S(N) + BASQ_TRCN_S(N))
      ENDDO                       ! END LOOP OVER REG 1-12

! SET ANNUAL F/I END-USE PRICES FOR UTILITY SECTOR

      SEC=5
      DO N=1,DNODES               ! NGTDM DMD REGIONS
        PQ_F(N) = 0.0             ! USED BY UTIL SEC=5
        PQ_I(N) = 0.0             ! USED BY UTIL SEC=5
        Q_F(N) = 0.0             ! USED BY UTIL SEC=5
        Q_I(N) = 0.0             ! USED BY UTIL SEC=5
      ENDDO

      DO J=1,NNGEM-1              ! UTILITY SUBREGIONS 1-16
        N = EMMSUB_NG(J)          ! NGTDM REGION 1-12

        NGUPR_F(J) = PKSHR_UDMD_F(J)  * NGUPR_SF(PKNET,J) + &
                 (1.-PKSHR_UDMD_F(J)) * NGUPR_SF(OPNET,J)
        NGUPR_I(J) = PKSHR_UDMD_I(J)  * NGUPR_SI(PKNET,J) + &
                 (1.-PKSHR_UDMD_I(J)) * NGUPR_SI(OPNET,J)

        PQ_F(N) = PQ_F(N) + NGUPR_F(J) * BASUQTY_F(J)
        PQ_I(N) = PQ_I(N) + NGUPR_I(J) * BASUQTY_I(J)
        Q_F(N) = Q_F(N) + BASUQTY_F(J)
        Q_I(N) = Q_I(N) + BASUQTY_I(J)
      ENDDO

      DO N=1,DNODES
        NGPR_F(SEC,N) = PQ_F(N) / Q_F(N)
        NGPR_I(SEC,N) = PQ_I(N) / Q_I(N)
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  RESET PREVIOUS DMD AND SUPPLY FOR CONV CHK NEXT CYCLE
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  FUNCTIONS USED:  NGDMD_CRVF
!                   NGDMD_CRVI
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_PREV
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'

      INTEGER*4  N             ! DEMAND NODES
      INTEGER*4  J             ! COUNTER
      INTEGER*4  S             ! SUPPLY NODE ID
      INTEGER*4  SEC           ! SECTOR ID

      REAL*4     NGDMD_CRVF    ! FUNCTION: NONUTILITY DMD CRV
      REAL*4     NGDMD_CRVI    ! FUNCTION: NONUTILITY DMD CRV
      REAL*4     NGUDMD_CRVF   ! FUNCTION: UTILITY DMD CRV
      REAL*4     NGUDMD_CRVI   ! FUNCTION: UTILITY DMD CRV
! --------------

!  DO NOT RESET IF EHISYR=LHISYR, AND MODYR=LHISYR

      IF (MODYR .GT. EHISYR) THEN 
! ----      
       DO N=1,DNODES            ! NGTDM DMD REGIONS
         DO SEC=1,DSEC-1        ! DEMAND SECTORS
           ZNGQTY_F(SEC,N) = 0.0
           ZNGQTY_I(SEC,N) = 0.0
         ENDDO
       ENDDO

       DO J=1,NNGEM-1
         ZNGUQTY_F(J) = 0.0
         ZNGUQTY_I(J) = 0.0
       ENDDO

       DO SEC=1,DSEC-1          ! NONUTILITY
         DO N=1,DNODES
           ZNGQTY_F(SEC,N) =  &
                NGDMD_CRVF(SEC,N,NGPR_F(SEC,N))    ! FUNCTION
           ZNGQTY_I(SEC,N) =  &
                NGDMD_CRVI(SEC,N,NGPR_I(SEC,N))    ! FUNCTION
         ENDDO
       ENDDO

       SEC = 5                  ! UTILITY
       DO J=1,NNGEM-1           ! UTILITY SUBREGIONS 1-16
         N = EMMSUB_NG(J)       ! NGTDM REGION
         ZNGUQTY_F(J) = NGUDMD_CRVF(J,NGUPR_F(J))            ! FUNCTION
         ZNGUQTY_I(J) = NGUDMD_CRVI(J,NGUPR_F(J))            ! FUNCTION
!CC      ZNGQTY_F(SEC,N) = ZNGQTY_F(SEC,N) + ZNGUQTY_F(J)
!CC      ZNGQTY_I(SEC,N) = ZNGQTY_I(SEC,N) + ZNGUQTY_I(J)
       ENDDO 
! ----
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  DEMAND CURVE FOR FIRM NONUTILITY SERVICE
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_PREV
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGDMD_CRVF(SEC,REG,PR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  REG         ! NODE ID
      INTEGER*4  SEC         ! SECTOR ID

      REAL*4     PR          ! PRICE ON DMD CURVE
      REAL*4     Q0          ! BASE QTY (COMP) IN CURVE EQ.
      REAL*4     P0          ! BASE PR IN CURVE EQ.

! ---------------

!   SET DMD = CONSTANT IF CURITR=1 -OR- HIST YEARS -OR- TRANS SECTOR

      IF ( CURITR.EQ.1 .OR. CONST_DMD.EQ.1 .OR. &
       SEC.EQ.4 .OR. PR.LE.0.0 .OR. P0.LE.0.0 ) THEN
          NGDMD_CRVF = BASQTY_F(SEC,REG)
          RETURN
      ENDIF

!   IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

      Q0 = BASQTY_F(SEC,REG)
      P0 = BASPR_F(SEC,REG)

      NGDMD_CRVF = Q0 * ((PR / P0) ** NONU_ELAS_F(SEC))

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  DEMAND CURVE FOR INTERRUPTIBLE NONUTILITY SERVICE
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_PREV
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGDMD_CRVI(SEC,REG,PR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  REG         ! NODE ID
      INTEGER*4  SEC         ! SECTOR ID

      REAL*4     PR          ! PRICE ON DMD CURVE
      REAL*4     Q0          ! BASE QTY (COMP) IN CURVE EQ.
      REAL*4     P0          ! BASE PR IN CURVE EQ.

! ---------------

!   SET DMD = CONSTANT IF HIST YEARS -OR- TRANS SECTOR

      IF ( CURITR.EQ.1 .OR. CONST_DMD.EQ.1 .OR.  &
       SEC.EQ.4 .OR. PR.LE.0.0 .OR. P0.LE.0.0 ) THEN
          NGDMD_CRVI = BASQTY_I(SEC,REG)
          RETURN
      ENDIF

!   IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

      Q0 = BASQTY_I(SEC,REG)
      P0 = BASPR_I(SEC,REG)

      NGDMD_CRVI = Q0 * ((PR / P0) ** NONU_ELAS_I(SEC))

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  DEMAND CURVE FOR FIRM UTILITY SERVICE
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_PREV
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGUDMD_CRVF(SREG,PR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  SREG        ! SUBREGION ID

      REAL*4     PR          ! PRICE ON DMD CURVE
      REAL*4     Q0          ! BASE QTY (COMP) IN CURVE EQ.
      REAL*4     P0          ! BASE PR IN CURVE EQ.

! ---------------

!   SET DMD = CONSTANT IF CURITR=1 -OR- HIST YEARS

      IF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN
          NGUDMD_CRVF = BASUQTY_F(SREG)
          RETURN
      ENDIF

!   IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

      Q0 = BASUQTY_F(SREG)
      P0 = BASUPR_F(SREG)

      NGUDMD_CRVF = Q0 * ((PR / P0) ** UTIL_ELAS_F(SREG))

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  DEMAND CURVE FOR INTERRUPTIBLE UTILITY SERVICE
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_PREV
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      REAL FUNCTION NGUDMD_CRVI(SREG,PR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  SREG        ! SUBREGION ID

      REAL*4     PR          ! PRICE ON DMD CURVE
      REAL*4     Q0          ! BASE QTY (COMP) IN CURVE EQ.
      REAL*4     P0          ! BASE PR IN CURVE EQ.

! ---------------

!   SET DMD = CONSTANT IF CURITR=1 -OR- HIST YEARS

      IF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN
          NGUDMD_CRVI = BASUQTY_I(SREG)
          RETURN
      ENDIF

!   IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

      Q0 = BASUQTY_I(SREG)
      P0 = BASUPR_I(SREG)

      NGUDMD_CRVI = Q0 * ((PR / P0) ** UTIL_ELAS_I(SREG))

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET BASPR AND BASUPR FOR USE BY DMD CURVE FUNCTIONS
!
!  STATUS:
!
!  CALLED BY: NGTDM_ITM (EVERY ITERATION)
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGITM_BASPR
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'

      INTEGER*4  N           ! NODE ID
      INTEGER*4  J           ! SUBREGION ID
      INTEGER*4  SEC         ! SECTOR ID

! ---------------

      DO SEC=1,DSEC-1
        DO N=1,DNODES
          BASPR_F(SEC,N) = NGPR_F(SEC,N)
          BASPR_I(SEC,N) = NGPR_I(SEC,N)
        ENDDO
      ENDDO

      DO J=1,NNGEM-1
        BASUPR_F(J) = NGUPR_F(J)
        BASUPR_I(J) = NGUPR_I(J)
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET ACTUAL/FINAL ARC CAPACITIES FOR HIST YEARS
!    ACTPCAP
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  HNGTDM_ITM
!
!  FREQUENCY:  EVERY NEMS ITERATION AND HIST YEAR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE HNGSET_ACTPCAP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4 A          ! ARC COUNTER
      INTEGER*4 SRC        ! SRC ID
      INTEGER*4 DEST       ! DEST ID

!--------------

      DO A=1,NARCS
        SRC = ARC_2NODE(A,1)
        DEST= ARC_2NODE(A,2)

        ACTPCAP(A) = CURPCAP(A,MODYR)
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET ACTUAL/FINAL ARC CAPACITIES
!    ACTPCAP
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  FREQUENCY:  EVERY NEMS ITERATION AND YEAR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGSET_ACTPCAP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4 A          ! ARC COUNTER
      INTEGER*4 SRC        ! SRC ID
      INTEGER*4 DEST       ! DEST ID

      REAL*4    PKFAC      ! ANNUAL TO PK SEASON CONVERSION
      REAL*4    OPFAC      ! ANNUAL TO OP SEASON CONVERSION
      REAL*4    PK_CAP     ! PK EQUIV CAP FOR FLORIDA
      REAL*4    OP_CAP     ! OP EQUIV CAP FOR FLORIDA
      REAL*4    PCAP       ! MAX CAP BETWEEN PK & OP EQUIV CAP
      REAL*4    MAXPCAP17  ! TOTAL CAPACITY OUT OF NODE 17 (2 arcs)
!--------------

      MAXPCAP17=0.0
      DO A=1,NARCS
        SRC = ARC_2NODE(A,1)
        DEST= ARC_2NODE(A,2)

        IF ((SRC .EQ. 6) .AND. (DEST .EQ. 10)) THEN     ! PIPE TO FLORIDA
            PKFAC = PKSHR_YR * PKUTZ(A)
            OPFAC = (1.-PKSHR_YR) * OPUTZ(A)

            PK_CAP = FLOW(PKNET,A) / PKFAC
            OP_CAP = FLOW(OPNET,A) / OPFAC
            PCAP = AMAX1( PK_CAP, OP_CAP )
            ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) )

          ELSE IF(SRC .GT. (TNODES+SNODES)) THEN        ! STORAGE ARCS
            PCAP = FLOW(PKNET,A) / PKUTZ(A)
            ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) )
!-EM4       ACTPCAP(A) = AMIN1( ACTPCAP(A), MAXPCAP(PKNET,A) )
            MAXPCAP(OPNET,A) = ACTPCAP(A)

          ELSE
            IF (SRC.EQ.17) THEN                     ! SUM ARCS LEAVING NODE 17
              MAXPCAP17=MAXPCAP17+MAXPCAP(OPNET,A)
            ENDIF
            IF (DEST.EQ.17) THEN
              MAXPCAP(OPNET,A) = AMAX1(MAXPCAP(OPNET,A),MAXPCAP17)
            ENDIF
            ACTPCAP(A) = MAXPCAP(OPNET,A)
        ENDIF
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  PREPROCESSING ROUTINES:
!    - CALL ROUTINE TO SET CONST DMD
!    - CALL ROUTINE TO SET MAX CAPACITY
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
!  FREQUENCY:  EVERY NEMS ITERATION AND YEAR
!
!  CALLS TO:   NGSET_NODECDMD
!              NGSET_MAXPCAP
!              NGSET_ZOGVAR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE NGITM_PRE
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngcdmdinc'


!--------------

      CALL NGSET_NODECDMD   ! SET NODE_CDMD: CONST DMD & SUP

      IF (CURITR .EQ. 1) THEN
        CALL NGSET_ZOGVAR   ! SET ZOG... VARIABLES FOR ITM USE
        CALL NGSET_MAXPCAP  ! SET MAX CAP ON ALL ARCS
      ENDIF

      RETURN
      END

!==================================================================
!
!  SET CONST DMD AND SUPPLY NET TOTALS:
!     NODE_CDMD
!
!  STATUS:  COMPLETE
!
!  CALLED BY: NGITM_PRE
!
!  FREQUENCY: EVERY ITERATION OF EVERY YEAR
!
!  NOTES:     ADGAS CHANGES EVERY NEMS ITERATION
!             ALL OTHER CONST SUP/DMD CHANGE EACH YEAR
!
!  INPUT VARIABLES:
!    YEAR_CDMD(2,24)
!    ZADGPRD(12)
!
!  OUTPUT VARIABLES:
!    NODE_CDMD(2,24)
!
!==================================================================
      SUBROUTINE NGSET_NODECDMD
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ngdtminc'
      include 'ogglobal'

      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  NET           ! REPRESENTS PK, OP NETWORK
      INTEGER*4  N,M           ! NODE ID
      INTEGER*4  SRC, DEST     !
      INTEGER*4  I             !
       character*5 dum
! -------------
!      if(modyr.eq.1990.and.curitr.eq.1) OPEN(UNIT=69,FILE="ngdebg1.txt")
!      if(modyr.eq.1990.and.curitr.eq.1) open(unit=68,file="ngdebg.txt")

      DO NET=1,NETWORK
        DO N=1,TNODES
          NODE_CDMD(NET,N) = 0.0
          MTH_CDMD(NET,N) = 0.0    ! peak month
        ENDDO
      ENDDO
      
      CALL NGSET_ADSUP
      CALL NGSET_FIXSUP    !  mvd fr ngset_yearcdmd
                               ! SECD FLOWS, CAN/MEX EXP, MEX IMP,
                               !  TOTAL SUPLMT, LNG, DISC, ANGTS,
                               !  SABLE ISLAND
      IF (MODYR.GT.LHISYR .OR. CURITR .EQ. 1) THEN    ! EVENTUALLY CHECK WHY HIST DIFF IF CALLED WHEN CURITR>1
        CALL NGSET_YEARCDMD
      ENDIF
                               ! PUT INTO CONST DMD VARIABLE
      DO NET=1,NETWORK
        DO N=1,TNODES
          NODE_CDMD(NET,N) = YEAR_CDMD(NET,N)
          MTH_CDMD(NET,N) = MTHYR_CDMD(NET,N)  ! peak month
        ENDDO
      ENDDO
      
!  LNG IMPORTS

      FIXSUPIP = 0.0 

! added 7-1-07 fr previous version by Yelena
!  LNG IMPORTS AND CONST ON/OFF SHORE ADGAS
!rmv yd1 see above      CALL NGSET_ADSUP
      DO I=1,SNODES
        N=MAP_NG(I)
        IF (SUPARRAY(I).EQ.0 .AND. (SUPTYPE(I) .EQ. 3 .OR. &
                     SUPTYPE(I) .EQ. 7 .OR. SUPTYPE(I) .EQ. 8)) THEN
          NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &
               PKSHR_PROD(I) * ZFIXSUP(I)
          NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) -  &
               (1.-PKSHR_PROD(I)) * ZFIXSUP(I)
              
               if (SUPTYPE(I) .EQ. 3) then
                 dum='lng  '
               else
                 dum='adgas'
               endif
          FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &
             PKSHR_PROD(I) * ZFIXSUP(I)
          FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &
             (1.-PKSHR_PROD(I)) * ZFIXSUP(I)
                               ! peak month
          IF (SUPTYPE(I) .EQ. 3) THEN
            PPERMTH(PKNET,I)=0.25
            PPERMTH(OPNET,I)=.125
          ENDIF
          MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &
               (PKSHR_PROD(I) * ZFIXSUP(I) * PPERMTH(PKNET,I))
          MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &
               ((1.-PKSHR_PROD(I)) * ZFIXSUP(I) * PPERMTH(OPNET,I))
        ENDIF
      ENDDO

!  LNG EXPORTS

      DO I=1,NLNGIMP
        N = LNG_XMAP(I,3)
        M = MNUMBX-4-NLNGIMP+I
        NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * (1.+PERLIQFUEL))
        NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * (1.-PKSHR_ELNG(I)) * (1.+PERLIQFUEL))
        MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * 0.25 * (1.+PERLIQFUEL))
        MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * (1.-PKSHR_ELNG(I))*0.125 * (1.+PERLIQFUEL))
      ENDDO
      NODE_CDMD(PKNET,7) = NODE_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * PKSHR_ELNG(I))
      NODE_CDMD(OPNET,7) = NODE_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * (1.-PKSHR_ELNG(I)))
      MTH_CDMD(PKNET,7)  = MTH_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * PKSHR_ELNG(I) * 0.25)
      MTH_CDMD(OPNET,7)  = MTH_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * (1.-PKSHR_ELNG(I))*0.125)

      DO I=1,DNODES
        DO NET=1,NETWORK
          NODE_CDMD(NET,I) = NODE_CDMD(NET,I) + ((BASQ_TRFV_SL(NET,I)+BASQ_TRPV_SL(NET,I) + &
                                                  BASQ_TRLN_SR(NET,I)+BASQ_TRLN_SS(NET,I))*(LNGV_LOSS/(1.-LNGV_LOSS)))
        ENDDO
        MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + ((BASQ_TRFV_SL(PKNET,I)+BASQ_TRPV_SL(PKNET,I) + &
                                                  BASQ_TRLN_SR(PKNET,I)+BASQ_TRLN_SS(PKNET,I)) *  0.25 * (LNGV_LOSS/(1.-LNGV_LOSS))) 
        MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + ((BASQ_TRFV_SL(OPNET,I)+BASQ_TRPV_SL(OPNET,I) + &
                                                  BASQ_TRLN_SR(OPNET,I)+BASQ_TRLN_SS(OPNET,I)) * 0.125 * (LNGV_LOSS/(1.-LNGV_LOSS)))
      ENDDO

!rmv yd1     DO I=1,NLNGIMP
!rmv yd1        N = MAPLNG_NG(I)
!rmv yd1        NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &
!rmv yd1             PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR)
!rmv yd1        NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) -  &
!rmv yd1             (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR)
!rmv yd1
!rmv yd1        FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &
!rmv yd1             PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR)
!rmv yd1        FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &
!rmv yd1             (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1                               ! peak month
!rmv yd1        MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &
!rmv yd1             (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * 0.25)    !1/4
!!           (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * PPERMTH(PKNET,N))
!rmv yd1        MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &
!rmv yd1             ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)* 0.125) !1/8
!!           ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)*PPERMTH(OPNET,N))
!rmv yd1      ENDDO
      
                               ! ADD CONST ON/OFF SHORE ADGAS
!rmv yd1      CALL NGSET_ADSUP
!rmv yd1      DO I=1,uSNODES          ! 1-20
!rmv yd1       IF (SUPARRAY(I).EQ.1 .AND. SUPTYPE(I).LT.3) THEN  ! Var conventional supply 
!rmv yd1        IF (I .LE. NSUPSUB) THEN        ! DEFINE L48 REG 1-12
!rmv yd1            N=SUPSUB_NG(I)
!rmv yd1          ELSE
!rmv yd1            N=SUPSUB_NG(OCSMAP(I-NSUPSUB))
!rmv yd1        ENDIF
!rmv yd1        NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &
!rmv yd1             PKSHR_PROD(I) * ZADGPRD(I)
!rmv yd1        FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &
!rmv yd1             PKSHR_PROD(I) * ZADGPRD(I)
!rmv yd1        NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) -  &
!rmv yd1             (1.-PKSHR_PROD(I)) * ZADGPRD(I)
!rmv yd1        FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &
!rmv yd1             (1.-PKSHR_PROD(I)) * ZADGPRD(I)
                               ! peak month
!rmv yd1        MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &
!rmv yd1             (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,I))      !by sup reg
!!           (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,N))      !by ng reg
!rmv yd1        MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &
!rmv yd1             ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,I)) !by sup reg
!!           ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,N)) !by ng reg
!rmv yd1       ENDIF
!rmv yd1      ENDDO

      RETURN
      END

!==================================================================
!
!  SET CONST DMD AND SUPPLY TOTALS:
!     YEAR_CDMD
!
!  STATUS:  COMPLETE
!
!  CALLED BY: NGSET_NODECDMD
!
!  FREQUENCY: 1ST ITERATION OF EVERY YEAR
!
!  INPUT VARIABLES:
!    ZTOTSUP(12)        defined in NGSET_TOTSUP
!    OGQNGIMP           from OGSM model
!    OGQNGEXP           from OGSM model
!    OGQANGTS(yr)       from OGSM model
!
!  OUTPUT VARIABLES:
!
!  INCLUDES:
!       <>L48 arc secondary flows
!       <>import /export arcs (including CAN intermediate arcs)
!       <>LNG imports
!       <>SNG from liquid
!       <>SNG from coal
!       <>other supplemental
!       <>Sable Island (part of Can const sup)
!        >ANGTS
!        >split CAN demand into P/O and add to CAN1 node
!        >split CAN flow-thru into P/O and add to
!            ?? border crossing path 3,15,24 only
!        >discrepancy
!
!==================================================================
      SUBROUTINE NGSET_YEARCDMD
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ngptmitm'
      include 'ngakinc'
      include 'ogglobal'
      include 'ngsteoinc'

      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  NET           ! REPRESENTS PK, OP NETWORK
      INTEGER*4  N             ! NODE ID
      INTEGER*4  SRC, DEST     !
      INTEGER*4  I,J,M         !
      INTEGER*4  BORDER        ! NODE AT BORDER CROSSING

      REAL*4     PKSHR         ! SHR OF FLOW TO PEAK NETWORK

! -------------

      DO NET=1,NETWORK
        DO N=1,TNODES
          YEAR_CDMD(NET,N) = 0.0
          MTHYR_CDMD(NET,N) = 0.0
        ENDDO
      ENDDO

!  IN FORECAST YEARS ASSIGN MEX I/E TO SEC FLOW ARRAYS

      IF (MODYR.GT.LHISYR) THEN
        DO I=1,NMEX
          J = NXMAPUS + I
          M = NCAN + I
          L = SNODE_2ARC(MEX_XMAP(I,2),MEX_XMAP(I,1))
          SAFLOW(L,MODYR) = oOGQNGIMP(M,CURIYR)
          L = SNODE_2ARC(MEX_XMAP(I,1),MEX_XMAP(I,2))
          SAFLOW(L,MODYR) = oOGQNGEXP(M,CURIYR)
        ENDDO
      ENDIF

!  SECONDARY FLOWS

      DO A=1,SARCS
       SRC = SARC_2NODE(A,1)
       DEST= SARC_2NODE(A,2)

       IF (SRC .NE. DEST) THEN
                               ! src = lower 48
        IF (SRC .LE. DNODES) THEN
          IF (DEST .LE. DNODES) THEN
            PKSHR = PKSHR_YR
          ELSE IF(DEST .LE. DNODES+NCAN_BRD) THEN
            PKSHR = PKSHR_ECAN
          ELSE IF(DEST .LE. DNODES+NCAN_BRD+NMEX) THEN
            PKSHR = PKSHR_EMEX
          ENDIF
                               ! src = canada border
        ELSE IF(SRC .LE. DNODES+NCAN_BRD) THEN
          IF (DEST .LE. DNODES) THEN
            PKSHR = PKSHR_ICAN
          ELSE IF(DEST .GT. DNODES+NCAN_BRD+NMEX) THEN
            PKSHR = PKSHR_ECAN
          ENDIF
                               ! src = mexico
        ELSE IF(SRC .LE. DNODES+NCAN_BRD+NMEX) THEN
          IF (DEST .LE. DNODES) THEN
            PKSHR = PKSHR_IMEX
          ENDIF
                               ! src = canada supply
        ELSE
          PKSHR = PKSHR_ICAN
        ENDIF

        YEAR_CDMD(PKNET,SRC) = YEAR_CDMD(PKNET,SRC) + &
             PKSHR * SAFLOW(A,MODYR)
        YEAR_CDMD(OPNET,SRC) = YEAR_CDMD(OPNET,SRC) + &
             (1.-PKSHR) * SAFLOW(A,MODYR)
        YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - &
             PKSHR * SAFLOW(A,MODYR)
        YEAR_CDMD(OPNET,DEST) = YEAR_CDMD(OPNET,DEST) - &
             (1.-PKSHR) * SAFLOW(A,MODYR)

        PTNETFLOW(PKNET,SRC,DEST) = PKSHR * SAFLOW(A,MODYR)
        PTNETFLOW(OPNET,SRC,DEST) = (1.-PKSHR) * SAFLOW(A,MODYR)

                               ! peak month
        MTHYR_CDMD(PKNET,SRC) = MTHYR_CDMD(PKNET,SRC) +  &
            (PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET))
        MTHYR_CDMD(OPNET,SRC) = MTHYR_CDMD(OPNET,SRC) +  &
            ((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET))
        MTHYR_CDMD(PKNET,DEST)= MTHYR_CDMD(PKNET,DEST)-  &
            (PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET))
        MTHYR_CDMD(OPNET,DEST)= MTHYR_CDMD(OPNET,DEST)-  &
            ((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET))

       ENDIF
      ENDDO

!  -SNG FROM LIQ
!  -SNG FROM COAL
!  -OTHER SUPPLEMENTAL
!yd1: IF SUPPLIES ABOVE ARE NO MORE FIXED CHANGE BELOW USING ZFIXSUP VARIABLE
      CALL NGSET_TOTSUP
      DO N=1,DNODES
        YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) - &
             PKSHR_SUPLM * ZTOTSUP(N)
        YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) -  &
             (1.-PKSHR_SUPLM) * ZTOTSUP(N)
                               ! peak month
        MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) - &
             (PKSHR_SUPLM * ZTOTSUP(N) * 0.25)               !1/4
!!           (PKSHR_SUPLM * ZTOTSUP(N) * PPERMTH(PKNET,N))
        MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) - &
             ((1.-PKSHR_SUPLM) * ZTOTSUP(N) * 0.125)         !1/8
!!           ((1.-PKSHR_SUPLM) * ZTOTSUP(N) * PPERMTH(OPNET,N))
      ENDDO

!  ANGTS

      DEST = NODE_ANGTS
      YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - &
           PKSHR_YR * QAK_ALB(MODYR)  
      YEAR_CDMD(OPNET,DEST) = YEAR_CDMD(OPNET,DEST) - &
           (1.-PKSHR_YR) * QAK_ALB(MODYR)  
                               ! peak month
      MTHYR_CDMD(PKNET,DEST) = MTHYR_CDMD(PKNET,DEST) - &
           (PKSHR_YR * QAK_ALB(MODYR) * 0.25)                !1/4
!!         (PKSHR_YR * QAK_ALB(MODYR) * PPERMTH(PKNET,DEST))
      MTHYR_CDMD(OPNET,DEST) = MTHYR_CDMD(OPNET,DEST) - &
           ((1.-PKSHR_YR) * QAK_ALB(MODYR) * 0.125)          !1/8
!!         ((1.-PKSHR_YR) * QAK_ALB(MODYR) * PPERMTH(OPNET,DEST))

! CANADIAN DMD

!     IF (MODYR.GT.LHISYR+2) CALL NGADJ_CNDMD    ! wop adjustment after steo years

      DO I=1,2           ! EAST & WEST CANADA
        N=TNODES-LNGNODES-2+I
        YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) + &
             PKSHR_CDMD * CN_DMD(I,MODYR) - &
             PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - &
             PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR)     
! add following and those below if want canada lng exports accounted for in canada production
!!!!         PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR)     add + to previous
        YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) + &
             (1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - &
             (1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - &
             (1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR) 
!!!!         (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR)    add + to previous
                               ! peak month
        MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) + (PERMTH(PKNET) * &
            (PKSHR_CDMD * CN_DMD(I,MODYR) - &
             PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - &
             PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR) ))    
!!!!         PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR) ))    delete )) from previous and add +
        MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) + (PERMTH(OPNET) * &
            ((1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - &
             (1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - &
             (1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR) ))
!!!!         (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR) ))  delete )) from previous and add +
      ENDDO

!  DISCREPANCY (ADD TO DEMAND)

                          ! L48
      IF (MODYR .GT. EHISYR) THEN
        IF (MODYR.GE.STEOYRS(1) .AND. (MODYR.LE.STPHAS_YR.OR.STPHAS_YR.EQ.0)) CALL xNGSTEO_BENCHDISCR
        IF (MODYR.EQ.STEOYRS(STEO_YEAR)+1 .AND. STPHAS_YR.EQ.0) CALL xNGSTEO_BENCHDISCR
        DO N=1,DNODES
          DO NET=1,NETWORK
            YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + &
                               DISCR(NET,N,MODYR)
                               ! peak month
            MTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + &
             (DISCR(NET,N,MODYR) * PERMTH(NET))
          ENDDO
        ENDDO
        
                          ! CANADA
        DO I=1,2
          N=TNODES-LNGNODES-2+I
          DO NET=1,NETWORK
            YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + CN_DISCR(NET,I)
                               ! peak month
            MTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + &
             (CN_DISCR(NET,I) * PERMTH(NET))
          ENDDO
        ENDDO
      ENDIF

      RETURN
      END

!==================================================================
!
!  ADJUST CANADIAN DEMANDS BASED OFF ENDOGENOUS READ GIVEN RELATIVE PRICE CHANGES
!
!  CALLED BY: NGSET_YEARCDMD
!
!  FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD
!
!  INPUT VARIABLES:  CN_DMD, IT_WOP, OGCNPPRD
!
!  OUTPUT VARIABLES: CN_DMD
!
!==================================================================

      SUBROUTINE NGADJ_CNDMD    
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngcdmdinc'
      include 'ogglobal'

      REAL*4 A,B,SA,SB,NA,NB
      REAL*4 BAS_CNPRC(IBASYR:IBASYR+MNUMYR-1)
      REAL*4 BAS_WOP(IBASYR:IBASYR+MNUMYR-1)

! EM4 TRACK (this subr NGADJ_CNDMD no longer called)
      DATA BAS_CNPRC /1.20,1.04,0.96,1.08,1.13,0.81,1.05,1.11,0.97,  &
            1.36,1.98,2.07,1.89,1.79,1.73,1.67,1.62,1.59,1.57,1.55,  &
            1.55,1.55,1.55,1.56,1.57,1.6,1.65,1.72,1.83,1.98,2.16,   &
            2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, &
            2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, &
            2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16/
! EM4 TRACK (this subr NGADJ_CNDMD no longer called)
      DATA BAS_WOP /19.58,16.25,15.44,16.36,12.60,13.61,16.06,14.14, 9.12,12.81, &
                   20.16,15.63,16.64,19.15,24.17,23.47,20.72,18.89,18.06,17.47, &
                   17.26,17.50,17.74,17.98,18.22,18.47,18.71,18.95,19.19,19.43, &
                   19.68,19.93,20.18,20.43,20.68,20.93,20.93,20.93,20.93,20.93,20.93, &
                   20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93, &
                   20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93/
 
!     DATA BAS_WOP /19.50,16.17,15.38,13.31,12.55,13.55,15.99,14.08,9.08, &
!                  12.75,20.10,15.61,16.54,18.31,17.05,16.50,16.61,16.71, &
!                  16.81,16.91,17.01,17.11,17.21,17.31,17.42,17.53,17.63, &
!                  17.74,17.85,17.96,18.06,18.22,18.38,18.53,18.68,18.84, &
!                  18.84,18.84,18.84,18.84,18.84/
      INTEGER*4 I

      NA = (oIT_WOP(CURIYR-1,1) / BAS_WOP(MODYR-1))
      NB = (oOGCNPPRD(2,CURIYR-1) / BAS_CNPRC(MODYR-1))
      NB = 0.0   ! temporarily remove impact due to gas price change

!     DO I=1,2
!       CN_DMD(I,MODYR) = CN_DMD(I,MODYR) * (NA**0.5)
!     ENDDO

      CN_DMD(2,MODYR) = CN_DMD(2,MODYR) * (NA**0.2)
  
      RETURN
      END

!==================================================================
!
!  ADJUST CANADIAN DEMANDS USING ESTIMATED EQUATION ATTEMPTING
!     TO REPRODUCE EXOGENOUS FORECAST ENDOGENOUSLY
!
!  CALLED BY: NGSET_YEARCDMD
!
!  FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD
!
!  INPUT VARIABLES:  CN_DMD, IT_WOP, OGCNPPRD
!
!  OUTPUT VARIABLES: CN_DMD
!
!==================================================================

      SUBROUTINE XNGADJ_CNDMD    
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngcdmdinc'
      include 'ogglobal'

      REAL*4 A,B

      INTEGER*4 I

      A = oIT_WOP(CURIYR-1,1) / oIT_WOP(CURIYR-2,1)
      B = oOGCNPPRD(2,CURIYR-1) / oOGCNPPRD(2,CURIYR-2)

      DO I=1,2
! EM4 TRACK -- routine not used
        CN_DMD(I,MODYR) = CN_DMD(I,MODYR-1) * &
          (1.08 + (0.048*A) + (-0.085*B) + (-0.0011*CURIYR))
      ENDDO
 
      RETURN
      END

!==================================================================
!
!  SET TOTAL SUPPLEMENTAL SUPPLIES IN BCF
!  - SNG FROM LIQUIDS
!  - SNG FROM COAL
!  - OTHER SUPPLEMENTAL
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_NODECDMD
!
!  FREQUENCY: 1ST ITERATION OF EVERY YEAR
!
!  INPUT VARIABLES:
!    SNGLIQ(12,yr)        defined in NGITM_READINIT
!    SNGCOAL(yr)          read in from miscdata
!    SNGOTH(12,yr)        other supplemental
!
!  OUTPUT VARIABLES:
!    ZTOTSUP(12)
!
!==================================================================
      SUBROUTINE NGSET_TOTSUP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'

      INTEGER*4  N                  ! NODE ID
      INTEGER*4  I                  ! LOOP AROUND SUPPLY SOURCE

      REAL*4     SUP_TOTAL          ! TOTAL SUPPLEMENTAL SUP (CL, LNG, OTH)
! -------------
!
!           -- NGTDM REGIONS --
!  SNGLIQ REGIONS  1  2  3  4  5  6  7  8  9 10 11 12  ! (region 3,12 used)
!  NODE_SNGCOAL    4
!  SNGOTH REGIONS  1  2  3  4  5  6  7  8  9 10 11 12
!
      DO N=1,DNODES
        ZTOTSUP(N) = 0.0
      ENDDO

      N = NODE_SNGCOAL         ! SNG FROM COAL
!yd1 CTG      ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(MODYR)

                               ! OTHER SUPPLEMENTAL (12)
                               ! SNG FROM LIQUIDS
      DO N=1,DNODES
        ZTOTSUP(N) = ZTOTSUP(N) + SNGOTH(N,MODYR)
        ZTOTSUP(N) = ZTOTSUP(N) + SNGLIQ(N,MODYR)
        ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(N,MODYR)
      ENDDO

      RETURN
      END

!==================================================================
!
!  SET FIXED SUPPLIES IN BCF
!  - SNG FROM LIQUIDS
!  - SNG FROM COAL
!  - OTHER SUPPLEMENTAL
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_NODECDMD
!
!  FREQUENCY: 1ST ITERATION OF EVERY YEAR
!
!  INPUT VARIABLES:
!    SNGLIQ(12,yr)        defined in NGITM_READINIT
!    SNGCOAL(12,yr)          read in from miscdata
!    SNGOTH(12,yr)        other supplemental
!    oOGQNGIMP       LNG IMPORTS
!    ZADGPRD(18)     AD GAS
!    QAK_ALB         ALASKA
!    CN_FIXSUP(cSNODES)  CANADA
!
!  OUTPUT VARIABLES:
!    ZFIXSUP(91)
!    PKSHR_PROD(91)
!
!==================================================================
      SUBROUTINE NGSET_FIXSUP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ogglobal'
      include 'ngakinc'


      INTEGER*4  N,S,P                  ! CANADA
      INTEGER*4  I                      ! LOOP AROUND SUPPLY SOURCE

! -------------
!
      DO I=1,SNODES
        ZFIXSUP(I) = 0.0
      ENDDO

!      DO I=1,SNODES
!        IF (SUPARRAY(I).EQ.0) THEN
!          IF (SUPTYPE(I).EQ.3) PKSHR_PROD(I)=PKSHR_ILNG(SUPRGN(I))
!          IF (SUPTYPE(I).EQ.4.OR.SUPTYPE(I).EQ.5.OR.SUPTYPE(I).EQ.6) PKSHR_PROD(I)=PKSHR_SUPLM
!          IF (SUPTYPE(I).EQ.7.OR.SUPTYPE(I).EQ.8) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I))
!          IF (SUPTYPE(I).EQ.9) PKSHR_PROD(I)=PKSHR_YR
!          IF (SUPTYPE(I).GE.10) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I))
!        ENDIF
!      ENDDO

      DO I=1,SNODES
        IF (I.GT.uSNODES) N=I-uSNODES
        IF (SUPARRAY(I).EQ.0) THEN
          IF (SUPTYPE(I).EQ.3 .AND. FIXLNGFLG) ZFIXSUP(I)=oOGQNGIMP(14+SUPREG(I),CURIYR)  !LNG
          IF (SUPTYPE(I).EQ.4) ZFIXSUP(I)=SNGCOAL(SUPREG(I),MODYR)  !SUPL FROM COAL
          IF (SUPTYPE(I).EQ.5) ZFIXSUP(I)=SNGLIQ(SUPREG(I),MODYR)  !SUPL FORM LIQ
          IF (SUPTYPE(I).EQ.6) ZFIXSUP(I)=SNGOTH(SUPREG(I),MODYR)  !SUPL FROM OTH
          IF (SUPTYPE(I).EQ.7) ZFIXSUP(I)=ZADGPRD(SUPREG(I))   !AD GAS ONSHORE
          IF (SUPTYPE(I).EQ.8) ZFIXSUP(I)=ZADGPRD(SUPREG(I)+NSRGN(7))  !AD GAS OFFSHORE
          IF (SUPTYPE(I).EQ.9) ZFIXSUP(I)=QAK_ALB(MODYR)     !ALASKA
!          IF (SUPTYPE(I).GE.10) ZFIXSUP(I)=CN_FIXSUP(N, MODYR)  !CANADA
        ENDIF
      ENDDO

      RETURN
      END

!==================================================================
!
!  FILL NG CONSTANST SUPPLY VARIABLES
!     ADGPRD(12)          -ONSHORE AND OFFSHORE
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY: NGSET_NODECDMD
!
!  FREQUENCY: EVERY ITERATION OF EVERY YEAR
!
!  INPUT VARIABLES:
!    OGPRDADON(17,yr)        from OGSM model
!    OGPRDADOF(3,yr)         from OGSM model
!
!  OUTPUT VARIABLES:
!    ZADGPRD(20)
!
!==================================================================
!
      SUBROUTINE NGSET_ADSUP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'nghistinc'
      include 'ngsteoinc'
      include 'ogglobal'

      INTEGER*4  I,J           ! COUNTERS
      INTEGER*4  N             ! NODE ID
! -------------

! NOTE: ADGAS FOR CANADIAN SUPPLY IS INCLUDED IN VARIABLE SUPPLY

      DO J=1,NSRGN(7)+NSRGN(8)
        ZADGPRD(J) = 0.0
      ENDDO

      IF (MODYR .LE. EHISYR) THEN
          DO I=1,NSUPSUB           ! ONSHORE AD GAS (17)
            N = SUPSUB_NG(I)
            ZADGPRD(I) = ZADGPRD(I) + HOGPRDAD(I,MODYR) * &
                        (1. - (PCTLP(N)*SCALE_LP(MODYR)))
          ENDDO

          DO I=1,NOCSREG           ! OFFSHORE AD GAS (3)
            J = I+NSUPSUB          ! 18-20
            N = SUPSUB_NG(OCSMAP(I))
            ZADGPRD(J) = ZADGPRD(J) + HOGPRDAD(J,MODYR) * &
                        (1. - (PCTLP(N)*SCALE_LP(MODYR)))
          ENDDO

        ELSE

          DO I=1,NSUPSUB           ! ONSHORE AD GAS (17)
            N = SUPSUB_NG(I)
            ZADGPRD(I) = ZADGPRD(I) + oOGPRDADON(I,CURIYR) * &
                        (1. - (PCTLP(N)*SCALE_LP(MODYR)))
            IF (I.EQ.12) ZADGPRD(I) = ZADGPRD(I) + oOGSHALENG(CURIYR) * &
                        (1. - (PCTLP(N)*SCALE_LP(MODYR)))
          ENDDO

          DO I=1,NOCSREG           ! OFFSHORE AD GAS (3)
            J = I+NSUPSUB          ! 18-20
            N = SUPSUB_NG(OCSMAP(I))
            ZADGPRD(J) = ZADGPRD(J) + oOGPRDADOF(I,CURIYR) * &
                        (1. - (PCTLP(N)*SCALE_LP(MODYR)))
          ENDDO
      ENDIF
      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  PUT OGSM VARIABLES INTO NG ZOG... VARIABLES
!     ZOGRESNG
!     ZOGPRRNG
!     ZOGCCAPPRD
!     ZOGTAXPREM
!
!  STATUS:  PLACEHOLDER
!
!  CALLED BY:  NGITM_PRE
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

      SUBROUTINE NGSET_ZOGVAR
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'
      include 'nghistinc'
      include 'ogglobal'

      INTEGER*4  I,J,L             ! COUNTERS

!----------------

      DO I=1,NSUPSUB               ! ONSHORE 1-17
        IF (CURIYR .GT. 1) THEN
          ZOGRESNGLAG1(I) = oOGRESNGON(I,CURIYR-1)
          ZOGPRRLAG(I) = oOGPRRNGON(I,CURIYR-1)
          ZOGRADNGLAG1(I) = oOGRADNGON(I,CURIYR-1)         
        ENDIF
        IF (CURIYR .GT. 2) THEN
          ZOGRESNGLAG2(I) = oOGRESNGON(I,CURIYR-2)
          ZOGRADNGLAG2(I) = oOGRADNGON(I,CURIYR-2)         
        ENDIF
        ZOGRESNG(I) = oOGRESNGON(I,CURIYR)        
        ZOGPRRNG(I) = oOGPRRNGON(I,CURIYR)
        ZOGRADNG(I) = oOGRADNGON(I,CURIYR)
        ZOGCCAPPRD(I) = oOGCCAPPRD(I,CURIYR)
        ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR)
        IF (MODYR.EQ.IBASYR) THEN
          ZWPROLL = 0.0
          ZWPROLL(I,1) = PSUP(I)
          ZWPRLAG(I) = PSUP(I)
        ELSEIF (MODYR.EQ.IBASYR+1) THEN
          ZWPRLAG(I) = HPSUP(I,MODYR)
        ELSEIF (MODYR.LE.EHISYR) THEN
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = HPSUP(I,MODYR-1)
          ZWPRLAG(I) = HPSUP(I,MODYR)
        ELSEIF (MODYR .EQ. EHISYR+1) THEN
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = HPSUP(I,MODYR-1)
          ZWPRLAG(I) = PSUP(I)            
        ELSE
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = PSUP(I)
          ZWPRLAG(I)  = PSUP(I)
        ENDIF
      ENDDO

      DO J=1,NOCSREG               ! OFFSHORE 1-3
        I = J+NSUPSUB
        IF (CURIYR .GT. 1) THEN
          ZOGRESNGLAG1(I) = oOGRESNGOF(J,CURIYR-1)
          ZOGPRRLAG(I) = oOGPRRNGOF(J,CURIYR-1)
          ZOGRADNGLAG1(I) = oOGRADNGOF(J,CURIYR-1)         
        ENDIF
        IF (CURIYR .GT. 2) THEN
          ZOGRESNGLAG2(I) = oOGRESNGOF(J,CURIYR-2)
          ZOGRADNGLAG2(I) = oOGRADNGOF(J,CURIYR-2)
        ENDIF
        ZOGRESNG(I) = oOGRESNGOF(J,CURIYR)
        ZOGPRRNG(I) = oOGPRRNGOF(J,CURIYR)
        ZOGRADNG(I) = oOGRADNGOF(J,CURIYR)        
        ZOGCCAPPRD(I) = 0.0
        ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR)
        
        IF (MODYR.EQ.IBASYR) THEN
          ZWPROLL(I,1) = PSUP(I)
          ZWPRLAG(I) = PSUP(I)
        ELSEIF (MODYR.EQ.IBASYR+1) THEN
          ZWPRLAG(I) = PSUP(I)
        ELSEIF (MODYR.LE.EHISYR) THEN
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = HPSUP(I,MODYR-1)
          ZWPRLAG(I) = HPSUP(I,MODYR)
        ELSEIF (MODYR .EQ. EHISYR+1) THEN
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = HPSUP(I,MODYR-1)
          ZWPRLAG(I) = PSUP(I)
        ELSE
          DO L=IROLL,2,-1
            ZWPROLL(I,L) = ZWPROLL(I,L-1)
          ENDDO
          ZWPROLL(I,1) = PSUP(I)
          ZWPRLAG(I)  = PSUP(I)
        ENDIF
      ENDDO
      IF (ZOGRESNG(18).GT.0.AND.ZOGRESNGLAG1(18).LT.1.0)  ZOGRESNGLAG1(18) = 1.0  ! START UP ATL OCS
      IF (CURIYR .GT. 1) THEN
        ZOGRESNGLAG1(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-1)
        ZOGPRRLAG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR-1) 
      ENDIF
      IF (CURIYR.GT.2) THEN
        ZOGRESNGLAG2(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-2)
      ENDIF
      ZOGRESNG(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR)
      ZOGPRRNG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR)
      ZOGCCAPPRD(SNODES-lSNODES-3) = 0.0
      ZOGTAXPREM(SNODES-lSNODES-3) = 0.0
      
      IF (MODYR.EQ.IBASYR) THEN
        ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3)
        ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)      
      ELSEIF (MODYR.EQ.IBASYR+1) THEN
        ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)
      ELSEIF (MODYR .LE.EHISYR) THEN
        DO J=IROLL,2,-1
          ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)
        ENDDO
        ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1)
        ZWPRLAG(SNODES-lSNODES-3) = HPSUP(SNODES-lSNODES-3,MODYR)
      ELSEIF (MODYR .EQ. EHISYR+1) THEN
        DO J=IROLL,2,-1
          ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)
        ENDDO
        ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1)
        ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)
      ELSE
        DO J=IROLL,2,-1
          ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)
        ENDDO
        ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3)          
        ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET MAXIMUM ALLOWABLE ANNUAL CAPACITY BY ARC
!     MAXPCAP
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGITM_PRE
!
!  NOTE:    THIS MUST BE CALLED AFTER ZOGRESNG IS SET IN NGSET_ZOGVAR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
      SUBROUTINE NGSET_MAXPCAP
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngptmitm'
      include 'ngsteoinc'
      include 'ngcdmdinc'

      REAL*4     MAXPRRCAN     ! MAX P/R FACTOR FOR CANADIAN SUPPLY

      INTEGER*4  L,A           ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  STID          ! STORAGE ID (1-14)
      INTEGER*4  SID           ! SUPPLY ID (1-21)
      INTEGER*4  LID           ! NODE ON LNG SUPPLY COUNT (1-3)
 
      INTEGER*4  NG_NREG       ! FUNCTION: MAPS SUP REG ID TO NG REG
      INTEGER*4  NREG          ! NG REG ID
! -------------

! IF BUILDS NOT ALLOWED, SET MAXPCAP = CURPCAP, EXCEPT FOR SUPPLY
! IF BUILDS ALLOWED, SET MAXPCAP = PTMAXPCAP OR PTMAXPSTR, EXCEPT SUPPLY

      DO L=1,NPROC
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
!        write(6,*) '2nd_LOOP',dest,arc_1,arc_2,l,nproc
      ENDDO

      DO L=1,NPROC
        DEST = PROC_ORD(L)
!        write(6,*) '1st_LOOP',dest,pknet,l,nproc
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
        DO A=ARC_1,ARC_2
          SRC = ARC_2NODE(A,1)

! NO BUILDS ALLOWED BEFORE NOBLDYR, AND FOR CANADIAN IMPORTS
          IF ((MODYR .LE. NOBLDYR) .OR. &
           ( ((SRC.GT.DNODES) .AND. (SRC.LE.DNODES+NCAN_BRD) .AND. &
             (DEST.LE.DNODES) .AND. (CNCAPSW.EQ.0)) )  .OR. &
           ( (DEST.GT.DNODES) .AND. (DEST.LE.DNODES+NCAN_BRD) .AND. &
             (SRC.EQ.TNODES-LNGNODES .OR. SRC.EQ.TNODES-LNGNODES-1) &
             .AND. (CNCAPSW.EQ.0) )) THEN

              IF ((SRC .LE. TNODES) .OR. &
                  (SRC .GT. (TNODES+SNODES))) THEN   ! PIPE & STORAGE
                MAXPCAP(PKNET,A) = CURPCAP(A,MODYR)
              ELSE                                   ! SUPPLY
                SID = SRC - TNODES
                IF(SUPARRAY(SID).NE.0) THEN 
                  NREG = NG_NREG(SID)           ! function: NG REG ID
                                                ! w/o L&P
                                                
                  IF (MODYR .LE. EHISYR) THEN
                    MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC
                  ELSE
                    IF (SUPTYPE(SID).EQ.14) THEN  ! LNG, hardcoded
                      LID = SID-FSRGN(14)+1           ! LNG SUP COUNT (1-3)
                      MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + &   !JBEMAX
                                         MAXPLNG(LID,OPNET,MODYR)       !JBEMAX
                    ELSE
                      MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &
                        MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))
                    ENDIF
                  ENDIF
                  CURPCAP(A,MODYR) = MAXPCAP(PKNET,A)
                ENDIF
              ENDIF

          ELSE
              IF (SRC .LE. TNODES) THEN              ! PIPELINE ARCS
                MAXPCAP(PKNET,A) = PTMAXPCAP(SRC,DEST)
              ELSE IF (SRC .GT. (TNODES+SNODES)) THEN   ! STR ARCS
                STID = SRC - (TNODES+SNODES)            ! 1-14
                MAXPCAP(PKNET,A) = PTMAXPSTR(STID)
              ELSE                                   ! SUPPLY ARCS
                SID = SRC - TNODES
                IF(SUPARRAY(SID).NE.0) THEN
                  NREG = NG_NREG(SID)           ! function: NG REG ID
                                                ! w/o L&P
                  IF (MODYR .LE. EHISYR) THEN
                    MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC
                  ELSE
                    IF (SUPTYPE(SID).EQ.10) THEN      ! CANADA, hardcoded
                      MAXPRRCAN = 1. + (MAXPRRFAC-1.) * 1.00
                      MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &
                        MAXPRRCAN * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))
                    ELSEIF (SUPTYPE(SID).EQ.14) THEN  ! LNG, hardcoded  !JBEMAX
                      LID = SID-FSRGN(14)+1           ! LNG SUP COUNT (1-3)
                      MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + &   !JBEMAX
                                         MAXPLNG(LID,OPNET,MODYR)       !JBEMAX
                    ELSE                                                !JBEMAX
                      MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &
                        MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))
                    ENDIF
                  ENDIF
                ENDIF
                CURPCAP(A,MODYR) = MAXPCAP(PKNET,A)
              ENDIF
          ENDIF
          MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)
        ENDDO
      ENDDO

      RETURN
      END

! =======================================================

      INTEGER FUNCTION NG_NREG(IREG)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'

      INTEGER*4  IREG         ! SUPPLY REG ID (1-17,18-20,21)
      INTEGER*4  DEST         ! TREE NODE
      INTEGER*4  I            ! OCS MAPPING INTO SUP REG ID
! -----------

      IF (SUPARRAY(IREG) .NE. 0) THEN
        NG_NREG = MAP_NG(IREG)
        IF (IREG .EQ. SNODES - 5)  NG_NREG = DNODES+1           ! FOR CAN SUPPLY
      ENDIF

      RETURN
      END

! =======================================================

      SUBROUTINE NGITM_DEBUG1
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  L,N,A,I,J,K   ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK

      REAL*4     P0, Q0, QMX   ! COST CURVE STARTING PARAMETERS

      LOGICAL PRTMAT/.TRUE./

! -------------

! PRINT NEW MATRICES: NODE_2ARC, ARC_2NODE, ARC_LOOP

      IF (PRTMAT) THEN      ! this print is turned off
        PRTMAT = .FALSE.
        IF (TNODES .LT. 25) THEN
            K=TNODES
          ELSE
            K=25
        ENDIF
        WRITE(NGOERR,*) ' NODE_2ARC: 1  2  3  4  5  6  7  8  9 10 ', &
           '11 12 13 14 15 16 17 18 19 20 21 22 23 24 25'
        DO I=1,NODES
          WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=1,K)
        ENDDO
        IF (TNODES .GT. 25) THEN
          K=TNODES
          IF (TNODES .GE. 50) K=50
          WRITE(NGOERR,*) ' NODE_2ARC:26 27 28 29 30 ... 50'
          DO I=1,NODES
            WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=26,K)
          ENDDO
        ENDIF
        IF (TNODES .GT. 50) THEN
          K=TNODES
          IF (TNODES .GE. 75) K=75
          WRITE(NGOERR,*) ' NODE_2ARC:51 52 53 54 55 ... 75'
          DO I=1,NODES
            WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=51,K)
          ENDDO
        ENDIF
        IF (TNODES .GT. 75) THEN
          K=TNODES
          IF (TNODES .GE. 100) K=50
          WRITE(NGOERR,*) ' NODE_2ARC:76 77 78 79 80 ... 100'
          DO I=1,NODES
            WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=76,K)
          ENDDO
        ENDIF

        WRITE(NGOERR,*) ' ARC_2NODE: SRC DEST'
        I=1
        DO WHILE (ARC_2NODE(I,1) .NE. 0)
         WRITE(NGOERR,101) I,(ARC_2NODE(I,J),J=1,2)
         I = I+1
        ENDDO

        WRITE(NGOERR,*) '           == PEAK ==    == OFFPEAK =='
        WRITE(NGOERR,*) ' ARC_LOOP: START  STOP   START  STOP'
        DO I=1,TNODES
          WRITE(NGOERR,102) I,(ARC_LOOP(PKNET,I,J),J=1,2), &
                               (ARC_LOOP(OPNET,I,J),J=1,2)
        ENDDO
      ENDIF
 100  FORMAT(5X,I2,4X,50(1X,I2))
 101  FORMAT(5X,I2,2X,2(3X,I2))
 102  FORMAT(5X,I2,2X,2(4X,I2),2X,2(4X,I2))

      RETURN
      END


! =======================================================
!
! REPORT NODE INFO ON ALL NETWORKS (PK, OP)
!
!     BKSTOP
!     PIPEFUEL
!     DEMAND
!     SHRPR
!     ENDPR
!
! =======================================================

      SUBROUTINE NGITM_DEBUG2(OUTPUT)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  L,N,A,I,J     ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  OUTPUT        ! OUTPUT UNIT NUMBER

      REAL*4     TDMD          ! TOTAL DMD ACROSS ALL NETWORKS (BCF)
      REAL*4     BK(NETWORK)   ! HOLDS BACKSTOP QTY
      REAL*4     PF(NETWORK)   ! HOLDS PIPE FUEL CONSUMPTION

      CHARACTER*3  ID          ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T)
      CHARACTER*2  RID(96)     ! USED TO TRANSFER VALUE TO CHARACTER
      CHARACTER*1  CNV(NETWORK)! FLAGS IF NON-CONVERGENCE ON SUPPLY
      CHARACTER*5  OUTID       ! USED TO DISTINGUISH LAST ITR FROM OTHERS
      CHARACTER*5  HEADID      ! USED TO DISTINGUISH LAST ITR FROM OTHERS

      DATA RID/'01','02','03','04','05','06','07','08','09','10', &
               '11','12','13','14','15','16','17','18','19','20', &
               '21','22','23','24','25','26','27','28','29','30', &
                   '31','32','33','34','35','36','37','38','39','40', &
                   '41','42','43','44','45','46','47','48','49','50', &
                   '51','52','53','54','55','56','57','58','59','60', &
                   '61','62','63','64','65','66','67','68','69','70', &
                   '71','72','73','74','75','76','77','78','79','80', &
                   '81','82','83','84','85','86','87','88','89','90', &
                   '91','92','93','94','95','96'/
! -------------

      IF (FCRL .EQ. 1) THEN
          OUTID = 'DB04Z'
          HEADID = 'DB04X'
          WRITE(OUTPUT,*) ' DB04X:  REPORT NODE LEVEL INFO'
        ELSE
          OUTID = 'DB02A'
          HEADID = 'DB02X'
          WRITE(OUTPUT,*) ' DB02X:  REPORT NODE LEVEL INFO'
      ENDIF

      WRITE(OUTPUT,105) HEADID
      WRITE(OUTPUT,115) HEADID

      DO DEST=1,NODES
        TDMD = 0.0
        DO NET=1,NETWORK
          TDMD = TDMD + NODE_DMD(NET,DEST)
          CNV(NET) = ' '
        ENDDO
        IF (DEST .GT. TNODES) THEN
          DO NET=1,NETWORK
            BK(NET) = 0.0
            PF(NET) = 0.0
          ENDDO
          IF (DEST .LE. TNODES+SNODES) THEN
            I = DEST - TNODES
            ID = 'S' // RID(I)       ! SUPPLY
            IF (PSUP_CNVG(PKNET,I) .EQ. 0) CNV(PKNET)= 'X'
            IF (PSUP_CNVG(OPNET,I) .EQ. 0) CNV(OPNET)= 'X'
          ENDIF
          IF (DEST .GT. TNODES+SNODES) THEN
            I = DEST - (TNODES+SNODES)
            ID = 'T' // RID(I)       ! STORAGE
          ENDIF
        ELSE
          DO NET=1,NETWORK
            BK(NET) = BKSTOP(NET,DEST)
            PF(NET) = PFUEL(NET,DEST)
          ENDDO
          IF (DEST .LE. DNODES) THEN
              ID = 'D' // RID(DEST)  ! L48 DEMAND NODES
            ELSE
              ID = 'I' // RID(DEST)  ! CAN/MEX NODES
          ENDIF
        ENDIF
        IF (DEST .LE. TNODES .OR. DEST .GT. TNODES+SNODES) THEN
          WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, &
           BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), &
           CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD
        ELSEIF (SUPARRAY(DEST-TNODES) .EQ. 1) THEN
            WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, &
             BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), &
             CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD
        ENDIF
      ENDDO

 105  FORMAT(1X,A5,25X, &
        2X,18('-'),'   PEAK  ',18('-'),7X, &
        2X,18('-'),' OFFPEAK ',18('-'), &
        2X,'TOTDMD')
 115  FORMAT(1X,A5,'   YR  ITR  CYC    NODE    ', &
        'BKSTOP   PFUEL  NETDMD    SHRPR      ENDPR',  &
        '      NODE  ', &
        'BKSTOP   PFUEL  NETDMD    SHRPR      ENDPR', &
        '     TOTDMD')
 120  FORMAT(1X,A5,1X,I4, 2(2X,I3), &
             2(2X,'|',I3,1X,A3, 3F8.1, F9.3,1X,A1,F9.3), &
             2X,F9.1)

      RETURN
      END

! =======================================================
!
! REPORT ARC LEVEL INFO FOR ALL NETWORKS
!      SHR, FLOW, ARC_ENDFEE, ARC,SHRFEE
!
! =======================================================

      SUBROUTINE NGITM_DEBUG3(OUTPUT)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  L,N,A,I,J     ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  OUTPUT        ! OUTPUT UNIT NUMBER

      REAL*4     CUR_EFFCAP(NETWORK,ARCS)    ! CURRENT EFFECTIVE CAPACITY
      REAL*4     MAX_EFFCAP(NETWORK,ARCS)    ! MAXIMUM EFFECTIVE CAPACITY
      REAL*4     PKFAC         ! FACTOR USE TO CALC EFF CAP
      REAL*4     TFLO          ! TOTAL ANNUAL FLOW ALONG ARC
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC

      CHARACTER*3  ID          ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T)
      CHARACTER*2  RID(96)     ! USED TO TRANSFER VALUE TO CHARACTER
      CHARACTER*5  OUTID       ! USED TO DISTINGUISH LAST ITR FROM OTHERS
      CHARACTER*5  HEADID      ! USED TO DISTINGUISH LAST ITR FROM OTHERS

      DATA RID/'01','02','03','04','05','06','07','08','09','10', &
               '11','12','13','14','15','16','17','18','19','20', &
               '21','22','23','24','25','26','27','28','29','30', &
                   '31','32','33','34','35','36','37','38','39','40', &
                   '41','42','43','44','45','46','47','48','49','50', &
                   '51','52','53','54','55','56','57','58','59','60', &
                   '61','62','63','64','65','66','67','68','69','70', &
                   '71','72','73','74','75','76','77','78','79','80', &
                   '81','82','83','84','85','86','87','88','89','90', &
                   '91','92','93','94','95','96'/
! -------------

      IF (NCRL .EQ. 1) THEN     ! store flow in PRV var for use next model yr
        DO NET=1,NETWORK
          DO A=1,NARCS
            PRVFLOW(NET,A) = FLOW(NET,A)
          ENDDO
          DO DEST=1,TNODES
            PRVNODE_DMD(NET,DEST) = NODE_DMD(NET,DEST)
          ENDDO
        ENDDO
        RETURN
      ENDIF

      IF (FCRL .EQ. 1) THEN
        OUTID = 'DB05Z'
        HEADID = 'DB05X'
        WRITE(OUTPUT,*) ' DB05X:  REPORT ARC LEVEL INFO'
      ELSE
        OUTID = 'DB03A'
        HEADID = 'DB03X'
        WRITE(OUTPUT,*) ' DB03X:  REPORT ARC LEVEL INFO'
      ENDIF

      WRITE(OUTPUT,105) HEADID
      WRITE(OUTPUT,115) HEADID

      DO L=1,NPROC
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          TFLO = 0.0
          DO NET=1,NETWORK
            MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)
            TFLO = TFLO + FLOW(NET,A)
          ENDDO
          IF (SRC .GT. TNODES+SNODES) THEN        ! storage
              CUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A)
            ELSE IF(SRC .LE. TNODES) THEN         ! pipe
              CUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR
            ELSE                                  ! supply
              CUR_EFFCAP(PKNET,A) =MAX_EFFCAP(PKNET,A)
          ENDIF
          CUR_EFFCAP(OPNET,A) = MAX_EFFCAP(OPNET,A)
          IF (SRC .GT. TNODES) THEN
            IF (SRC .LE. TNODES+SNODES) THEN
              I = SRC - TNODES
              ID = 'S' // RID(I)       ! SUPPLY
            ENDIF
            IF (SRC .GT. TNODES+SNODES) THEN
              I = SRC - (TNODES+SNODES)
              ID = 'T' // RID(I)       ! STORAGE
            ENDIF
          ELSE
            IF (SRC .LE. DNODES) THEN
                ID = 'D' // RID(SRC)  ! L48 DEMAND NODES
              ELSE
                ID = 'I' // RID(SRC)  ! CAN/MEX NODES
            ENDIF
          ENDIF
          if (modyr.gt.1990) WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (SRC, ID, DEST, &
            ARC_SHRFEE(NET,A), ARC_SHRPR(NET,A), SHR(NET,A,MODYR), shr(net,a,modyr-1), &
            FLOW(NET,A), CUR_EFFCAP(NET,A), MAX_EFFCAP(NET,A), &
            NET=1,NETWORK), TFLO
        ENDDO
      ENDDO

 105  FORMAT(1X,A5,26X, &
        3X,20('-'),'   PEAK   ',20('-'),13X, &
        3X,20('-'),'  OFFPEAK ',20('-'))
 115  FORMAT(1X,A5,'   YR ITR CYC     SRC    DEST   ', &
        'ARCFEE  SHRPR     SHR     FLOW   EFFCAP   EFFMAX',  &
        '     SRC    DEST   ', &
        'ARCFEE  SHRPR     SHR     FLOW   EFFCAP   EFFMAX', &
        '     TOTFLO')
 120  FORMAT(1X,A5,1X,I4, 2(1X,I3), 2(2X,'|',2X,I3, 1X,A3, 1X,I3, &
           4F8.3, 3F9.1), 2X,F9.1)

      RETURN
      END

!
! =======================================================
!
      SUBROUTINE NGITM_DEBUG6(OUTPUT)
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  L,N,A,I,J     ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  OUTPUT        ! OUTPUT UNIT NUMBER

      REAL*4     DUMMY/0.0/    ! DUMMY VARIABLE

! -------------


! REPORT NODE INFO: DMD, SHRPR, ENDPR FOR ALL NETWORKS

      WRITE(OUTPUT,*) ' REPORT COST INFO: CYCLE= ',CYCLE
      WRITE(OUTPUT,105)  
      WRITE(OUTPUT,115)

      DO L=1,NPROC
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
        DO A=ARC_1,ARC_2
          SRC = ARC_2NODE(A,1)
          WRITE(OUTPUT,120) CYCLE, SRC, DEST,  &
           (ARC_ENDFEE(NET,A),  &
           NODE_ENDPR(NET,SRC), NODE_ENDPR(NET,DEST), &
           NODE_SHRPR(NET,SRC), NODE_SHRPR(NET,DEST),  &
           NET=1,2)
        ENDDO
      ENDDO
      DO N=1,SNODES
       IF (SUPARRAY(N).EQ.1) THEN 
        DEST = TNODES+N
        SRC = 0
        WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, &
             DUMMY, NODE_ENDPR(NET,DEST), &
             DUMMY, NODE_SHRPR(NET,DEST),  &
             NET=1,2)
       ENDIF
      ENDDO
      DO N=1,STNODES
        DEST = TNODES+SNODES+N
        SRC = 0
        WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, &
             DUMMY, NODE_ENDPR(NET,DEST), &
             DUMMY, NODE_SHRPR(NET,DEST),  &
             NET=1,2)
      ENDDO


 105  FORMAT(1X,'YR=',14X,20('-'),' PEAK ',20('-'), &
        6X,20('-'),'  OFFPEAK  ',20('-'))
 115  FORMAT(1X,'CYCLE', 3X,'NODE', &
        7X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', &
        9X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', &
       /8X,'S  D',2(20X,'S',7X,'D',9X,'S',7X,'D'))
 120  FORMAT(1X,I3, 2X,2I3, 2X,2(3X,F8.2,2(2X,2F8.2)))

      RETURN
      END

!
! =======================================================
!
      SUBROUTINE NGITM_DEBUG7(OUTPUT)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'nghistinc'
      include 'ngptmitm'       ! temp

      INTEGER*4  L,N,A,I,J     ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST          ! NODE ON TREE (DEST NODE)
      INTEGER*4  SRC           ! SOURCE NODE ALONG ARC
      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  OUTPUT        ! OUTPUT UNIT NUMBER

      REAL*4 TDMD              ! TOTAL DMD ACROSS ALL NETWORKS (BCF)
      REAL*4 TFLO              ! TOTAL FLO ACROSS ALL NETWORKS (BCF)
      REAL*4 PKSH              ! PKSHR FOR FLOWS/DMDS (FRACTION)
      REAL*4 DIFFLO            ! HAFLOW - TDMD
      REAL*4 TMAX(NETWORK)     ! TOTAL MAX FLO (BCF)
      REAL*4 DUMMY0/0.0/       ! DUMMY VARIABLE
      REAL*4 DUMMY1/1.0/       ! DUMMY VARIABLE
      REAL*4 NGSET_MAXFLO      ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4 TEMP              ! TEMPORARY HOLDING VARIABLE
      REAL*4 ATEMP(NXMAPCN)    ! TEMPORARY HOLDING VARIABLE

      CHARACTER*1 X(NETWORK)   ! INDICATOR FOR DMD > QMAX

! -------------


! REPORT NODE INFO: DMD, SHRPR, ENDPR FOR ALL NETWORKS

      WRITE(OUTPUT,*) ' REPORT NODE LEVEL INFO: CYCLE= ',CYCLE
      WRITE(OUTPUT,105) MODYR
      WRITE(OUTPUT,115)

      DO L=1,NPROC
        DEST = PROC_ORD(L)
        SRC = 0
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)

        TDMD = 0.0
        DO NET=1,NETWORK
          TDMD = TDMD + NODE_DMD(NET,DEST)
          TMAX(NET) = 0.0
          DO A=ARC_1,ARC_2
            SRC = ARC_2NODE(A,1)
            IF (NET .EQ. OPNET) THEN   !  ????
              MAXFLO(NET,A) = NGSET_MAXFLO(NET,A)         ! FUNCTION
            ENDIF
            IF ((NET .EQ. OPNET) .AND. (SRC .GT. TNODES+SNODES)) THEN
                ! DO NOT ADD STORAGE CAPACITY TO OP TMAX
              ELSE
                TMAX(NET) = TMAX(NET) + MAXFLO(NET,A)
            ENDIF
          ENDDO
          X(NET)=' '
          IF (NODE_DMD(NET,DEST) .GT. TMAX(NET)) THEN
            X(NET)='X'
          ENDIF
        ENDDO
        IF (TDMD .GT. 0.0) THEN
          PKSH  = NODE_DMD(PKNET,DEST) / TDMD
         ELSE
          PKSH  = 0.0
        ENDIF
        WRITE(OUTPUT,110) CYCLE, DEST,  &
         (NODE_DMD(NET,DEST), TMAX(NET), X(NET), &
         NET=1,NETWORK), TDMD, PKSH

        DO A=ARC_1,ARC_2          ! LOOP OVER INPUT ARCS
          SRC = ARC_2NODE(A,1)
          TFLO = 0.0
          DO NET=1,NETWORK
            TFLO = TFLO + FLOW(NET,A)
            X(NET)=' '
            IF (FLOW(NET,A) .GT. MAXFLO(NET,A)) THEN
              X(NET)='X'
            ENDIF
          ENDDO
          IF (TFLO .GT. 0.0) THEN
            PKSH  = FLOW(PKNET,A) / TFLO
           ELSE
            PKSH  = 0.0
          ENDIF
          IF (MODYR .LE. EHISYR) THEN
              DIFFLO = HAFLOW(A,MODYR) - TFLO
            ELSE
              DIFFLO = 0.0
          ENDIF
          WRITE(OUTPUT,120) CYCLE, SRC, DEST, &
            (SHR(NET,A,MODYR), FLOW(NET,A), MAXFLO(NET,A), X(NET), &
            NET=1,NETWORK), TFLO, DIFFLO, PKSH
        ENDDO
      ENDDO

      WRITE(OUTPUT,*) ' XXX  SECONDARY CAPACITY'
      WRITE(OUTPUT,*) ' XXX    SRC   DEST        CAP     FLOW'

      DO A=1,SARCS
        SRC = SARC_2NODE(A,1)
        DEST= SARC_2NODE(A,2)
        WRITE(OUTPUT,130) SRC,DEST,SACTPCAP(A),SAFLOW(A,MODYR)
      ENDDO

! temp
      WRITE(OUTPUT,150)
      DO L=1,NPROC
        DEST = PROC_ORD(L)
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
        DO A=ARC_1,ARC_2
          SRC = ARC_2NODE(A,1)
          IF (SRC.LE.TNODES) THEN
            TEMP = PTMAXPCAP(SRC,DEST)
          ELSE
            TEMP = 0.0
          ENDIF
          WRITE(OUTPUT,140) MODYR,SRC,DEST,TEMP, &
               MAXPCAP(OPNET,A),CURPCAP(A,MODYR),ACTPCAP(A)
        ENDDO
      ENDDO
 140  FORMAT(1X,'PTMAXPCAP: ',I4,I4,I4,4F10.2)
 150  FORMAT(1X,'PTMAXPCAP:  YR SRC DEST PTMAXPCAP   MAXPCAP   CURPCAP   ACTPCAP')

! temp
      IF (MODYR.EQ.LASTYR+IBASYR-1) THEN
        WRITE(OUTPUT,*) 'ARC_VARTAR-CN: YEAR    23->13    23->14', &
          '    23->15    24->16    24->17    24->18    24->19'  
        DO NET=1,NETWORK
          WRITE(OUTPUT,*) 'ARC_VARTAR-CN: NET= ',NET
          DO L=IBASYR,LASTYR+IBASYR-1
            DO I=1,NXMAPCN
              IF (CAN_XMAPCN(I,1).NE.15) THEN
                ATEMP(I) = ARC_VARTAR(NET,NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1)),L)
              ELSE
                ATEMP(I) = 0.0
              ENDIF
            ENDDO
            WRITE(OUTPUT,160) L, (ATEMP(I),I=1,NXMAPCN)   ! WRITE CANADIAN ARC_VARTAR
          ENDDO
        ENDDO
      ENDIF
 160  FORMAT(1X,'ARC_VARTAR-CN: ',I4,8F10.3)

 130  FORMAT(1X,'XXX',2I7,2X,2F9.3)

 105  FORMAT(1X,'YR=',I4,2X,15X,'  PEAK   ',19X,' OFFPEAK ')
 115  FORMAT(1X,'CYCLE', 2X,'SRC DEST', &
        5X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', &
        6X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', &
        5X,'TDMD',2X,'DIFF',5X,'PKDMD')
 110  FORMAT(1X,I3, 6X, I3, 1X,2( 9X,     2(F9.2),A1), &
        1X,F9.2,6X,1X,F9.3)
 120  FORMAT(1X,I3, 3X,2I3, 1X,2(2X,F7.3, 2(F9.2),A1), &
        1X,F9.2,1X,F6.0,F9.3)

      RETURN
      END

! ====================================

      SUBROUTINE NGTDM_SENSITIVITY(A,B)
      IMPLICIT NONE

      REAL*4      A
      REAL*4      B

! -------

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  HISTORICAL YEAR VERSION OF NEW INTERSTATE TRANSMISSION MODULE (ITM)
!
!  STATUS:
!
!  CALLED BY:     NGMAIN
!
!  CALLS:         NGITM_PRE            ! PREPROCESSOR
!                 NGSET_NODEDMD        ! SET NET DMDS
!                 HNGDOWN_TREE(NET)    ! DEFINE NODE DMDS & FLOWS
!                 HNGSET_SUPPR         ! SET SUPPLY PR USING CURVE
!                 NGSET_ARCFEE         ! SET FIX/VAR TAR ALONG ARCS
!                 NGSET_STORPR         ! SET STORAGE PRICE
!                 NGUP_TREE(NET)       ! SET NODE PRICE
!                 NGSET_SECPR          ! SET END-USE SECTOR PRICES
!  ???            NGSET_PREV           ! SET PREV SUP/DMD FOR CONV CHK NXT CYC
!  ???            NGITM_BASPR          ! SET BASPR FOR PO IN DMD CURVE EQ
!  ???            NGSET_ACTPCAP        ! SET ACTUAL/FINAL CAPACITIES ON ARCS
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
      SUBROUTINE HNGTDM_ITM
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'

      INTEGER*4  NET          ! REPRESENTS PK,OP NETWORK
! --------------

      CALL NGITM_PRE                ! PREPROCESSING FOR THE ITM

      CALL NGSET_NODEDMD            ! SPLIT F/I INTO P/O; ADD CONST DMD

      IF (CURITR .EQ. 1) THEN
        CALL NGHIST_DISCR             ! SET DISCREPANCIES
      ENDIF

      CALL HNGDOWN_TREE             ! SET HIST SHARES, FLOWS BY SEASON

      CALL HNGSET_SUPPR             ! SET HIST SUPPLY PRICES BY SEASON

      CALL NGSET_ARCFEE             ! SET FIX/VAR TAR ALONG ARCS

      DO NET=NETWORK,1,-1           ! SET NODE & STORAGE PR
        IF (NET .EQ. PKNET) CALL NGSET_STORPR
        CALL NGUP_TREE(NET)
      ENDDO

      CALL HNGSET_CGPR              ! SET CITYGATE PRICES AND BENCHMARK FAC

!???  CALL NGITM_BASPR              ! SET BASPR FOR PO IN DMD CURVE EQ
      CALL HNGSET_ACTPCAP            ! SET ACTUAL/FINAL CAPACITIES ON ARCS

                                    ! DEBUG REPORTS
      IF (NGDBGITR(4,2) .OR. NGDBGITR(4,12)) THEN
        CALL NGITM_DEBUG2(NGOTREE)
        CALL NGITM_DEBUG3(NGOTREE)
      ENDIF

      IF (NGDBGITR(4,1) .OR. NGDBGITR(4,11)) THEN
        CALL NGITM_DEBUG7(NGOBAL)
      ENDIF

      RETURN
      END

!=========================================================================

!   SET SEASONAL DISCREPANCIES TO BALANCE SUPPLY AND DEMAND (L48)
!   FIRST BALANCE CANADA
!   CALLED IF CURITR.EQ.1 .AND. MODYR.LE.EHISYR

!=========================================================================
      SUBROUTINE NGHIST_DISCR
      IMPLICIT NONE
!
      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'nghistinc'
      include 'ngcdmdinc'
      include 'ngitminc'
      include 'ngtdminc'

      REAL*4 PKDISCR   !  DISCREPANCY IN THE PEAK PERIOD
      REAL*4 OPDISCR   !  DISCREPANCY IN THE OFFPEAK PERIOD
      REAL*4 NATDISCR  !  NATIONAL ANNUAL DISCREPANCY
      REAL*4 REGADJ    !  REGIONAL ADJUSTMENT OF REGIONAL ANNUAL DISCREPANCY
      REAL*4 PKADJ     !  REGIONAL DIFFERENCE PEAK DISCREANCY AND ANNUAL DISCR

      INTEGER*4 A      !  ARC
      INTEGER*4 AI     !  IMPORT ARC
      INTEGER*4 AE     !  EXPORT ARC
      INTEGER*4 NET    !  NETWORK INDEX
      INTEGER*4 I,J,K,L,M        ! GENERIC INDICES

!----------------------------------------------------------------------

!  SET DISCREPANCY FOR PEAK/OFFPEAK AND EAST/WEST CANADA

      DO M=1,2       ! EAST=1, WEST=2
        HCN_DISCR(PKNET,M,MODYR) = HNETWTH(STNODES-2+M,MODYR) - &
                                   NODE_DMD(PKNET,TNODES-LNGNODES-2+M)
        HCN_DISCR(OPNET,M,MODYR) = -1.* HNETINJ(STNODES-2+M,MODYR) - &
                                   NODE_DMD(OPNET,TNODES-LNGNODES-2+M)
      ENDDO
      HCN_DISCR(PKNET,2,MODYR) = HCN_DISCR(PKNET,2,MODYR) + &
         (QSUP(SNODES-lSNODES-3) * PKSHR_PROD(SNODES-lSNODES-3) )
      HCN_DISCR(OPNET,2,MODYR) = HCN_DISCR(OPNET,2,MODYR) + &
         (QSUP(SNODES-lSNODES-3) * (1. - PKSHR_PROD(SNODES-lSNODES-3)) )

      DO I=1,NXMAPCN
        AI = NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1))
        AE = SNODE_2ARC(CAN_XMAPCN(I,1),CAN_XMAPCN(I,2))
        IF (CAN_XMAPCN(I,2) .EQ. TNODES-LNGNODES) THEN
          M = 2
          HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - &
             ( HAFLOW(AI,MODYR) * PKSHR_ICAN)
          HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - &
             ( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) )
        ELSE
          M = 1
          IF (I .NE. 3) THEN
            HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - &
             ( HAFLOW(AI,MODYR) * PKSHR_ICAN )
            HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - &
             ( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) )
          ENDIF
        ENDIF
      ENDDO

! SPREAD DISCREPANCY IN EACH SEASON EVENLY BETWEEN EAST AND WEST
!   AND ADJUST NODE DEMAND TO ACCOUNT FOR DISCREPANCY

      PKDISCR = HCN_DISCR(PKNET,1,MODYR) + HCN_DISCR(PKNET,2,MODYR)
      OPDISCR = HCN_DISCR(OPNET,1,MODYR) + HCN_DISCR(OPNET,2,MODYR)
      DO M=1,2
        HCN_DISCR(PKNET,M,MODYR) = PKDISCR / 2.
        HCN_DISCR(OPNET,M,MODYR) = OPDISCR / 2.
                                   ! ADJUST HAFLOW BTWN 24-23
        IF (M .EQ. 1) THEN
          A=NODE_2ARC(24,23)
          HAFLOW(A,MODYR) = HAFLOW(A,MODYR) + HCN_DISCR(PKNET,M,MODYR) + &
                                              HCN_DISCR(OPNET,M,MODYR)
        ENDIF
                                   ! ADJUST NODE_DMD FOR DISCR
        I = TNODES-LNGNODES-2+M
        NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + &
                            HCN_DISCR(PKNET,M,MODYR)
        NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + &
                            HCN_DISCR(OPNET,M,MODYR)
        NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + &
                             HCN_DISCR(PKNET,M,MODYR)
        NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + &
                             HCN_DISCR(OPNET,M,MODYR)
        YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + &
                             HCN_DISCR(PKNET,M,MODYR)
        YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + &
                             HCN_DISCR(OPNET,M,MODYR)
      ENDDO
      
!-----------------------------------------------------------

! DETERMINE L48 NATIONAL DISCREPANCY IN THE PEAK AND OFFPEAK PERIODS

!   ADD ADJUSTMENT FOR 8->4 AND 8->9 TRANSFER TO 17->4 AND 18->9

      IF (MODYR .LT. LHISYR) THEN
        HBAL_ITM(9,MODYR) = HBAL_ITM(9,MODYR) + DEL_DISCR9(MODYR)
        HBAL_ITM(4,MODYR) = HBAL_ITM(4,MODYR) + DEL_DISCR4(MODYR)
        HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR9(MODYR)
        HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR4(MODYR)
      ELSE IF (MODYR .EQ. LHISYR) THEN
        DO I=1,DNODES
          HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR-1)
        ENDDO
      ENDIF

!   SUM INTO NATIONAL PEAK AND OFFPEAK DISCREPANCY

      PKDISCR = 0.0
      OPDISCR = 0.0
      NATDISCR = 0.0
                                 ! CANADIAN IMPORTS
      DO I=1,NXMAPUS
        IF (I .NE. 3) THEN
          J = NODE_2ARC(CAN_XMAPUS(I,2),CAN_XMAPUS(I,1))
          PKDISCR = PKDISCR + (HAFLOW(J,MODYR) * PKSHR_ICAN)
          OPDISCR = OPDISCR + (HAFLOW(J,MODYR) * (1.-PKSHR_ICAN))
        ENDIF
      ENDDO
                                 ! L48 NA PRODUCTION
      DO I=1,uSNODES
       IF (SUPARRAY(I) .EQ. 1) THEN
        PKDISCR = PKDISCR + (QSUP(I) * PKSHR_PROD(I))
        OPDISCR = OPDISCR + (QSUP(I) * (1.-PKSHR_PROD(I)))
       ENDIF
      ENDDO
                                 ! LNG IMPORTS WHEN NOT FIXED
      IF (.NOT.FIXLNGFLG) THEN
        DO I=1,NLNGTER-3
          A = NODE_2ARC(LNG_XMAP(I,2),LNG_XMAP(I,3))
          PKDISCR = PKDISCR + FLOW(PKNET,A)
          OPDISCR = OPDISCR + FLOW(OPNET,A)
        ENDDO
      ENDIF

                                 ! REMAINDER
      NATDISCR = 0.0
      DO I=1,DNODES
        PKDISCR = PKDISCR - PFUEL(PKNET,I) + HNETWTH(I,MODYR) - &
           NODE_DMD(PKNET,I)
        OPDISCR = OPDISCR - PFUEL(OPNET,I) - HNETINJ(I,MODYR) - &
           NODE_DMD(OPNET,I)
        NATDISCR = NATDISCR + HBAL_ITM(I,MODYR)
      ENDDO

!   ADJUST NGA BALANCING ITEM IF PEAK AND OFFPEAK SUM DON'T EXACTLY EQUAL

      REGADJ = (NATDISCR - (PKDISCR + OPDISCR)) / FLOAT(DNODES)

      DO I=1,DNODES
        HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR) - REGADJ
      ENDDO

!   DISTRIBUTE PEAK AND OFFPEAK DISCREPANCY OVER REGIONS, BY ADJUSTING
!   ANNUAL REGIONAL DISCREPANCY

      PKADJ = ((PKDISCR - OPDISCR) / FLOAT(DNODES) ) / 2.
      DO I=1,DNODES
        DISCR(PKNET,I,MODYR) = (HBAL_ITM(I,MODYR) / 2.) + PKADJ
        DISCR(OPNET,I,MODYR) = HBAL_ITM(I,MODYR) - DISCR(PKNET,I,MODYR)

        NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + DISCR(PKNET,I,MODYR)
        NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + DISCR(OPNET,I,MODYR)
        NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR)
        NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR)
        YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR)
        YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR)
      ENDDO
      
      RETURN
      END

! ==================================================================
!
!  SET SHARE OF FLOWS ALONG PIPE ARCS ONLY
!     PSHR
!
!  STATUS:
!
!  CALLED BY:  HNGDOWN_TREE
!
! =================================================================

      SUBROUTINE XNGSHR_PIPE(NET,DEST,PSHR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'

      INTEGER*4  A            ! ARC COUNTER
      INTEGER*4  ARC_1,ARC_2  ! INPUT ARC COUNTERS
      INTEGER*4  SRC, DEST    ! NODE ID
      INTEGER*4  NET          ! PK/OP NETWORK ID

      REAL*4     PSHR(NETWORK,ARCS)   ! SHARE FOR FLOW ALONG PIPE
      REAL*4     TPFLOW(NETWORK)      ! HOLDS TOTAL FLOW ALONG PIPE
! ----------

      TPFLOW(NET) = 0.0
      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

      DO A=ARC_1,ARC_2
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN   ! PIPE ARCS ONLY
          TPFLOW(NET) = TPFLOW(NET) + FLOW(PKNET,A)+ &
                                      FLOW(OPNET,A)
        ENDIF
      ENDDO

      DO A=ARC_1,ARC_2
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN        ! PIPE ARCS ONLY
          PSHR(NET,A) = (FLOW(PKNET,A)+FLOW(OPNET,A)) &
                      / TPFLOW(NET)
        ENDIF
      ENDDO

      RETURN
      END

! ==================================================================
!
!  SET VARIABLES NEEDED FOR FORECAST YEARS
!     FLOW
!     SHR
!     HPFUEL_FAC    (used to set PFUEL_FAC)
!     ARC_PFUEL
!
!  STATUS:
!
!  CALLED BY:  HNGTDM_ITM
!
! =================================================================

      SUBROUTINE HNGDOWN_TREE
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'
      include 'ngcdmdinc'

      INTEGER*4  A            ! ARC COUNTER
      INTEGER*4  ARC_1,ARC_2  ! INPUT ARC COUNTERS
      INTEGER*4  SRC, DEST    ! NODE ID
      INTEGER*4  NET, NET0    ! PK/OP NETWORK ID
      INTEGER*4  L,STID       ! COUNTER
      INTEGER*4  CAPFLG       ! FLAG TO CONTINUE CHK FOR FLO ADJ DUE TO CAP
      INTEGER*4  CHKCHNG      ! FLG TO ADJ FLOWS ON OTHER NET
      INTEGER*4  CHKOLD       ! FLG FROM PREV NET ADJ
      INTEGER*4  CNT          ! COUNTER TO PREVENT INF LOOP

      REAL*4     PNODE_DMD(NETWORK)   ! NODE DMD FOR PIPE ARCS
      REAL*4     PSHR(NETWORK,ARCS)   ! SHARE FOR FLOW ALONG PIPE
      REAL*4     TPNODE_DMD           ! ANNUAL NODE DMD FOR PIPE ARCS
      REAL*4     THAFLOW              ! TOTAL FLOW ALONG PIPE INTO NODE
      REAL*4     NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC
      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4     FAC(DNODES)   ! SEASONAL PK/OP NET NODE DMD SHARE
      REAL*4     FLO_ADJ       ! ADJUSTMENT TO HAFLOW FOR HIST YRS
! ----------

      DO L=1,NPROC
        DEST = PROC_ORD(L)

! ADD PIPEFUEL TO NODE_DMD AND SET PFUEL FACTOR (HPFUEL_FAC)
! SET HISTORICAL INTRAREG FLOW FACTOR (HFLO_FAC)

        DO NET=1,NETWORK
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)
                          ! ADD NET INJECTIONS TO OFFPEAK DMDS
          DO A=ARC_1,ARC_2
            SRC = ARC_2NODE(A,1)
            IF ( (NET .EQ. PKNET) .AND. (SRC .GT. (TNODES+SNODES))) THEN
              STID = SRC - (TNODES+SNODES)
              NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + &
                                     HNETINJ(STID,MODYR)
            ENDIF
          ENDDO
                                     ! DEFINE INTRAREGIONAL FLOW FACTOR AND FLOWS
                                     !   HFLO_FAC = INTRA_FLO / NODE_DMD(W/O PF)
          IF (DEST .LE. DNODES) THEN
            IF (NET .EQ. PKNET) THEN
              FAC(DEST) = NODE_DMD(PKNET,DEST) / &
                   (NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST))
             ELSE
              FAC(DEST) = NODE_DMD(OPNET,DEST) / &
                   (NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST))
            ENDIF
            A = SNODE_2ARC(DEST,DEST)
            INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR)
            HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / &
                                       NODE_DMD(NET,DEST)
          ENDIF
          NODE_DMD(NET,DEST) = NODE_DMD(NET,DEST) + PFUEL(NET,DEST)
         
! TEMPCODE: 09/03/97
          INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST)
! TEMPCODE: 09/03/97
          IF (NODE_DMD(NET,DEST)-PFUEL(NET,DEST) .GT. 0.) THEN
            HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / &
                   (NODE_DMD(NET,DEST) + FIXSUPIP(NET,DEST) - PFUEL(NET,DEST))
           ELSE
            HPFUEL_FAC(NET,DEST,MODYR) = 0.0
          ENDIF
          PNODE_DMD(NET) = NODE_DMD(NET,DEST)
          
! ADJUST NODE DMD TO BE NET OF SUPPLY AND STORAGE
! (NODE DMD FOR PIPE ARCS ONLY)

          DO A=ARC_1,ARC_2
            SRC = ARC_2NODE(A,1)
            IF (SRC .GT. TNODES) THEN
              PNODE_DMD(NET) = PNODE_DMD(NET) - FLOW(NET,A)
            ENDIF
          ENDDO
          IF (NGDBGITR(4,6)) THEN
            IF (PNODE_DMD(NET) .LE. -0.001) THEN
              WRITE(NGOERR,*) 'ATTN1 HNGDOWN_TREE: NET,DEST,MODYR=', &
               NET,DEST,MODYR,'  PNODE_DMD= ',PNODE_DMD(NET)
            ENDIF
          ENDIF
        ENDDO

! CHECK TOTAL HAFLOWS FOR PIPE ARCS AGAINST TOTAL PNODE_DMD
        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)
        THAFLOW = 0.0
        DO A=ARC_1,ARC_2
          SRC = ARC_2NODE(A,1)
          IF (SRC .LE. TNODES) THEN
            THAFLOW = THAFLOW + HAFLOW(A,MODYR)
          ENDIF
        ENDDO
        TPNODE_DMD = PNODE_DMD(PKNET)+PNODE_DMD(OPNET)
        
        IF (NGDBGITR(4,6)) THEN
          IF (ABS(TPNODE_DMD - THAFLOW) .GT. 0.01) THEN
              WRITE(NGOERR,*) ' ATTN6 HNGDOWN_TREE: DEST,MODYR= ', &
               DEST,MODYR,' TPNODE_DMD= ', TPNODE_DMD,' THAFLOW= ', &
               THAFLOW
          ENDIF
        ENDIF

! ADJUST HAFLOW TO BETTER MATCH DEMANDS

!CCC    IF (MODYR .EQ. LHISYR) THEN
          DO A=ARC_1,ARC_2
            SRC = ARC_2NODE(A,1)
            IF ((SRC .GT. DNODES) .AND. (SRC .LE. (TNODES-LNGNODES-2))) THEN
              THAFLOW = THAFLOW - HAFLOW(A,MODYR)
              TPNODE_DMD = TPNODE_DMD - HAFLOW(A,MODYR)
            ENDIF
          ENDDO
          IF (THAFLOW .GT. 0.0) THEN
            FLO_ADJ = TPNODE_DMD / THAFLOW
            DO A=ARC_1,ARC_2
              SRC = ARC_2NODE(A,1)
              IF   (SRC .LE. DNODES) THEN
!CCC          IF ( (SRC .LE. DNODES) .OR.
!CCC *            ((DEST.GT.(TNODES-2)) .OR. (DEST.LE.TNODES))) THEN
                HAFLOW(A,MODYR) = HAFLOW(A,MODYR) * FLO_ADJ
              ENDIF
            ENDDO
          ENDIF
!CCC    ENDIF

! DETERMINE SHARES AMONG PIPE ARCS ONLY FOR PK NETWORK
      
        CALL HNGSHR_PIPE(PKNET,DEST,PSHR)

! SET PK FLOWS ALONG PIPE ARCS

        ARC_1 = ARC_LOOP(PKNET,DEST,1)
        ARC_2 = ARC_LOOP(PKNET,DEST,2)

        DO A=ARC_1,ARC_2
          SRC = ARC_2NODE(A,1)
          IF (SRC .LE. TNODES) THEN
            FLOW(PKNET,A) = PSHR(PKNET,A) * PNODE_DMD(PKNET)
          ENDIF
        ENDDO

! CHECK FLOWS AGAINST MAX EFF CAPACITY ON EACH NETWORK
! AND RESET FLOWS ALONG PIPE ARCS

        CAPFLG = 1
        CHKOLD = 1
        NET = 0
        CNT = 1

        DO WHILE ((CAPFLG .EQ. 1) .AND. (CNT .LE. 5))
          IF (NET .EQ. PKNET) THEN
              NET = OPNET
              NET0= PKNET
            ELSE
              NET = PKNET
              NET0= OPNET
          ENDIF

          CALL HNGCHK_PIPFLO(NET,DEST,PNODE_DMD(NET),CHKCHNG)

          IF ((CHKCHNG .EQ. 0) .AND. (CHKOLD .EQ. 0)) THEN
            CAPFLG = 0
          ELSE
            CAPFLG = 1
            CHKOLD = CHKCHNG

            ARC_1 = ARC_LOOP(NET,DEST,1)
            ARC_2 = ARC_LOOP(NET,DEST,2)
            DO A=ARC_1,ARC_2
              SRC = ARC_2NODE(A,1)
              IF (SRC .LE. TNODES) THEN
                FLOW(NET0,A) = HAFLOW(A,MODYR) - FLOW(NET,A)
              ENDIF
            ENDDO
          ENDIF

          CNT = CNT + 1
        ENDDO

        IF (CAPFLG .EQ. 1) THEN
          WRITE(NGOERR,*) 'ATTN2 HNGDOWN_TREE: MAX EFF CAP REACHED ', &
           'ON ALL ARCS FOR NODE ',DEST,' ITR=',CURITR,' YEAR=',MODYR
        ENDIF

! REDEFINE SHARES AMONG PIPE ARCS ONLY
       
        CALL HNGSHR_PIPE(PKNET,DEST,PSHR)
        CALL HNGSHR_PIPE(OPNET,DEST,PSHR)

! SET PFUEL ALONG PIPE ARCS
! SET SHR ALONG ALL INPUT ARCS

        DO NET=1,NETWORK
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)

          DO A=ARC_1,ARC_2
            SRC = ARC_2NODE(A,1)
            IF (SRC .LE. TNODES) THEN
              ARC_PFUEL(NET,A) = PSHR(NET,A) * &
                (PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST))
            ENDIF

            IF (SRC.GT.TNODES.AND. SRC.LE.TNODES+SNODES) THEN
              IF(SUPARRAY(SRC-TNODES).NE.0) THEN
                IF (ARC_1.EQ.ARC_2) THEN
                  SHR(NET,A,MODYR) = 1.0
                ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN
                  SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST)
                ELSE
                  SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)
                ENDIF
                NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)
              ENDIF
            ELSE
              IF (ARC_1.EQ.ARC_2) THEN
                SHR(NET,A,MODYR) = 1.0
              ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN
                SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST)
              ELSE
                SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)
              ENDIF
              NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)
            ENDIF

! DETERMINE REMAINING FLOW ALONG ARCS
            FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A)
          ENDDO
          BKSTOP(NET,DEST) = 0.0
        ENDDO
      ENDDO

      RETURN
      END

! ==================================================================
!
!  SET SHARE OF FLOWS ALONG PIPE ARCS ONLY
!     PSHR
!
!  STATUS:
!
!  CALLED BY:  HNGDOWN_TREE
!
! =================================================================

      SUBROUTINE HNGSHR_PIPE(NET,DEST,PSHR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'

      INTEGER*4  A            ! ARC COUNTER
      INTEGER*4  ARC_1,ARC_2  ! INPUT ARC COUNTERS
      INTEGER*4  SRC, DEST    ! NODE ID
      INTEGER*4  NET          ! PK/OP NETWORK ID

      REAL*4     PSHR(NETWORK,ARCS)   ! SHARE FOR FLOW ALONG PIPE
      REAL*4     TPFLOW(NETWORK)      ! HOLDS TOTAL FLOW ALONG PIPE
! ----------

      TPFLOW(NET) = 0.0
      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

      DO A=ARC_1,ARC_2
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN   ! PIPE ARCS ONLY
          TPFLOW(NET) = TPFLOW(NET) + FLOW(NET,A)
        ENDIF
      ENDDO

      DO A=ARC_1,ARC_2
        SRC = ARC_2NODE(A,1)
        IF (SRC .LE. TNODES) THEN        ! PIPE ARCS ONLY
         IF (TPFLOW(NET).NE. 0.0) THEN
          PSHR(NET,A) = FLOW(NET,A) / TPFLOW(NET)
         ELSE
          PSHR(NET,A) = 0.0
         ENDIF
        ENDIF
      ENDDO

      RETURN
      END

! ==================================================================
!
!  CHECK FLOWS AGAINST MAX EFFECTIVE CAPACITY FOR PIPE ARCS ONLY
!  ON EACH NETWORK
!
!  STATUS:
!
!  CALLED BY:  HNGDOWN_TREE
!
! =================================================================

      SUBROUTINE HNGCHK_PIPFLO(NET,DEST,PDMD,CHKCHNG)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'

      INTEGER*4  NET           ! REPRESENTS PK,OP NETWORK
      INTEGER*4  A             ! COUNTERS
      INTEGER*4  ARC_1,ARC_2   ! INPUT ARC COUNTERS
      INTEGER*4  DEST, SRC     ! NODE ON TREE (SOURCE OR DEST NODE)

      INTEGER*4  CHNG, CHK     ! FLAGS TO REDEFINE SHARES
      INTEGER*4  CHKCHNG       ! FLAGS IF ANY FLOW CHANGE WAS MADE
      INTEGER*4  OLDFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)
      INTEGER*4  MAXFLG(ARCS)  ! FLAG TO TRACK ARCS AT MAX SHR

      REAL*4     NGSET_MAXFLO  ! FUNCTION: SETS MAX FLOW ON ARC
      REAL*4     SUMFLO        ! TOTAL FLOWS NOT AT MAX
      REAL*4     SUMMAX        ! TOTAL FLOWS AT MAX
      REAL*4     SUMREM        ! TOTAL FLOWS REMAINING FOR DISTRIBUTION
      REAL*4     TMAXFLO       ! TOTAL MAX FLOW INTO NODE
      REAL*4     PDMD          ! NODE DMD FOR PIPE ARCS
      REAL*4     DELTA         ! FLOW ADJUSTMENT QUANTITY
      REAL*4     UTZ           ! UTILZ FOR SEASON
      REAL*4     CMAX          ! MAXIMUM AVAILABLE PIPEFLOW BY ARC

! ---------

      ARC_1 = ARC_LOOP(NET,DEST,1)
      ARC_2 = ARC_LOOP(NET,DEST,2)

! SET MAXIMUM FLOWS AND TOTAL FLOWS

      TMAXFLO = 0.0
      DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
        SRC = ARC_2NODE(A,1)
        OLDFLG(A) = 0.
        MAXFLG(A) = 0.
        MAXFLO(NET,A) = NGSET_MAXFLO(NET,A)         ! FUNCTION
        IF (SRC .LE. TNODES) THEN                   ! PIPELINE ARCS ONLY
!CC       IF (NET .EQ. PKNET) THEN
!CC         UTZ = PKUTZ(A)
!CC       ELSE IF (NET .EQ. OPNET) THEN
!CC         UTZ = OPUTZ(A)
!CC       ENDIF
!CC       CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A))
          CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A))
          TMAXFLO = TMAXFLO + CMAX
        ENDIF
      ENDDO

! CHECK IF TOTAL FLOWS LESS THAN MAXIMUM FLOWS

      CHKCHNG = 0
      IF (PDMD .LE. TMAXFLO+.001) THEN        ! DMD < TMAXFLO
        CHNG = 1
        DO WHILE (CHNG .EQ. 1)
          CHK = 0
          DO A=ARC_1,ARC_2      ! LOOP OVER INPUT ARCS
            SRC = ARC_2NODE(A,1)
            IF (SRC .LE. TNODES) THEN         ! PIPELINE ARCS ONLY

! CHECK IF ARC FLOW GREATER THAN MAX

              IF (FLOW(NET,A) .GE. MAXFLO(NET,A)) THEN
                DELTA = FLOW(NET,A) - MAXFLO(NET,A)
                                              ! SET FLOW = MAX FLOW
                FLOW(NET,A) = MAXFLO(NET,A)
                                              ! ADJUST CORRESP OP FLOW
                MAXFLG(A) = 1
                IF (MAXFLG(A) .NE. OLDFLG(A)) THEN
                  CHK = 1
                  CHKCHNG = 1
                  OLDFLG(A) = MAXFLG(A)
                ENDIF
              ENDIF
            ENDIF
          ENDDO

! IF FLOWS HAVE BEEN ADJUSTED, NEED TO REALLOCATE OVER OTHER ARCS
          IF (CHK .EQ. 1) THEN
              SUMMAX = 0.0
              SUMREM = 0.0
              SUMFLO = 0.0

              DO A=ARC_1,ARC_2                 ! LOOP OVER INPUT ARCS
                SRC = ARC_2NODE(A,1)
                IF (SRC .LE. TNODES) THEN      ! PIPELINE ARCS ONLY
                  IF (MAXFLG(A) .EQ. 0) THEN
                    SUMFLO = SUMFLO + FLOW(NET,A)
                  ELSE
                    SUMMAX = SUMMAX + FLOW(NET,A)
                  ENDIF
                ENDIF
              ENDDO
              SUMREM = PDMD - (SUMFLO+SUMMAX)
                                      ! DISTRIBUTE OVER UNCONSTR ARCS
              DO A=ARC_1,ARC_2        ! LOOP OVER INPUT ARCS
                SRC = ARC_2NODE(A,1)
                IF (SRC .LE. TNODES) THEN      ! PIPELINE ARCS ONLY
                  IF (MAXFLG(A) .EQ. 0) THEN
                    IF (SUMFLO .GT. 0.) THEN
                      DELTA = (SUMREM * (FLOW(NET,A) / SUMFLO))
                    ELSE
                      DELTA = 0.0
                    ENDIF
                                              ! SET FLOW = MAX FLOW
                    FLOW(NET,A) = FLOW(NET,A) + DELTA
                                              ! ADJUST CORRESP OP FLOW
                  ENDIF
                ENDIF
              ENDDO
            ELSE
              CHNG = 0
          ENDIF
        ENDDO

      ELSE           ! DMD GREATER THAN EFFECTIVE CAPACITY

        IF (NGDBGITR(4,6)) THEN
          WRITE(NGOERR,*) 'ATTN3 NGCHK_MAXFLO: PIPE DMD > MAX EFF CAP ', &
           'FOR NET,NODE,ITR,YEAR:',NET,DEST,CURITR,MODYR, &
           '   PNDOE_DMD, MAX: ', PDMD, TMAXFLO
        ENDIF
      ENDIF

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET SUPPLY WELLHEAD PRICES BY REGION AND PEAK
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  HNGTDM_ITM
!
!  CALLS    :  NGSET_SUPPR
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE HNGSET_SUPPR
      IMPLICIT NONE

      include 'parametr'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'

      INTEGER*4  N,S            ! COUNTERS
      INTEGER*4  NET            ! NETWORK ID (1=PK, 2=OP)
! -----------

      DO NET=1,NETWORK
        DO N=1,NODES
          NODE_ENDPR(NET,N) = 0.0
          NODE_SHRPR(NET,N) = 0.0
        ENDDO
      ENDDO

      DO NET=1,NETWORK
        DO S=1,SNODES
          N = TNODES + S
          IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N)
        ENDDO
      ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

      CALL NGSET_SUPPR

      DO NET=1,NETWORK
        DO S=1,SNODES
         IF (SUPARRAY(S).EQ.1) THEN 
          N = TNODES + S
          NODE_ENDPR(NET,N) = NODE_PSUP(NET,S)
          NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

          NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S)
          NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S)
         ENDIF
        ENDDO
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SET BENCHMARK FACTORS FOR CITYGATE, MEX, LNG PRICES
!  AND SET CITYGATE PRICES FOR EACH PK/OP NETWORK
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  HNGTDM_ITM
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
      SUBROUTINE HNGSET_CGPR
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'nghistinc'
      include 'ngptmitm'
      include 'ogglobal'

      INTEGER*4  N             ! DEMAND NODES
      INTEGER*4  NET           ! REPRESENTS PK/OP NETWORKS

      REAL*4     NGPIPE_VARTAR  ! FUNCTION (from ptm)
      REAL*4     TEMP           ! TEMPORARILY HOLD INTRA VARTAR
! -------------

      DO N=1,DNODES               ! LOOP OVER END-USE DEMAND NODES
        DO NET=1,NETWORK          ! LOOP OVER PK/OP NETWORKS
          INTRAREG_TAR(NET,N) = INTRAREG_FIXTAR(NET,N) + &
                 NGPIPE_VARTAR(NET,NARCS+N,INTRA_FLO(NET,N,MODYR))     ! PTM function

!CCC      TEMP = INTRAREG_TAR(NET,N) - INTRAREG_FIXTAR(NET,N)
!CCC      WRITE(4,1000) MODYR,NET,N,INTRAREG_FIXTAR(NET,N),
!CCC *      TEMP,INTRAREG_TAR(NET,N),INTRA_FLO(NET,N,MODYR)
!1000          FORMAT(' INTRAH',I4,2I3,3F6.3,F10.2)

          CGPR(NET,N) = NODE_ENDPR(NET,N) + INTRAREG_TAR(NET,N) + &
                        INTRAST_TAR(N)
          HCG_BENCH(NET,N,MODYR) = HCGPR(NET,N,MODYR) - CGPR(NET,N)
          CGBENCH(NET,N) = HCG_BENCH(NET,N,MODYR)
        ENDDO
      ENDDO

      CALL NGDBUG_DTM03(0)

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  SUBROUTINE TO RESET PREVIOUS YEAR'S SHARES IN ANTICIPATION OF
!  PLANED CAPACITY BUILDS
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGMAIN
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

      SUBROUTINE NGPCAP_ADJSHR
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngtdminc'
      include 'ngitminc'
      include 'ngcdmdinc'
      include 'ngakinc'
      include 'ogglobal'

      INTEGER*4 NET        ! REPRESENTS PK, OP NETWORK
      INTEGER*4 A,A2,I     ! COUNTER
      INTEGER*4 ARC_0      ! ARC FROM CANADA W/ANGTS FLOW
      INTEGER*4 ARC_1      ! FIRST ARC INTO DEST
      INTEGER*4 ARC_2      ! LAST ARC INTO DEST
      INTEGER*4 DEST       ! DESTINATION NODE INDEX
      INTEGER*4 SRC        ! SOURCE NODE INDEX
      INTEGER*4 AKPIP      ! SET TO 1 IF CH IN ANGTS VOLS, ELSE 0
      INTEGER*4 A16,A17,A9 ! ARCS FOR 16->4 AND 17->4 AND 9->12
      INTEGER*4 SRG        ! SUPPLY REGION 1-20
      INTEGER*4 ORG        ! OFFSHORE REGION 1-3
      INTEGER*4 ASUP       ! ARC CORRESPONDING TO SUPPLY CURVE BEING ADJUSTED

      REAL*4    SHRSUM     ! SUM OF ADJUSTED SHARES INTO A NODE
      REAL*4    TOTFLW     ! LAST YEAR'S TOTAL FLOW INTO A NODE
      REAL*4    CHQAK_ALB  ! ANNUAL CHANGE IN ANGTS VOLUMES
      REAL*4    PRDEXP     ! INITAL GUESS AT BIG INCREASE IN PRODUCTION LEVELS (EXPECTED PRODUCTION)
      REAL*4    PRDEXPLAG  ! PRDEXP LAGGED
      REAL*4    PRDCHG     ! RATIO OF THIS YEAR TO LAST YEAR'S EXPECTED PRODUCTION
      REAL*4    SHR1617    ! SUM OF REVISED SHARES FR 16->4 AND 17->4
      REAL*4    FLDEL16,FLDEL17,FLDEL18,FLDEL19  ! EST INCR IN FLW ON BRD ARCS ATTRIBUTED TO ANGTS
       
      LOGICAL   ONCE       ! SET TO FALSE IF RESERVES START IN ATLANTIC OFFSHORE
      DATA ONCE /.TRUE./

!-------------------------------
! SET ANGTS VOLUME INCREASE

      CHQAK_ALB = QAK_ALB(MODYR) - QAK_ALB(MODYR-1) + QMD_ALB(MODYR) - QMD_ALB(MODYR-1)

! ADJUSTMENT FOR ARCS NOT RELATED TO ANGTS

      DO NET=1,NETWORK
        DO A=1,NARCS
          SRC = ARC_2NODE(A,2)
          DEST = ARC_2NODE(A,1)
          IF (  (DEST.LE.DNODES .OR. DEST.EQ.23 .OR. DEST.EQ.24) .AND.  &    !YD1LNG: LNG ARCS WILL BE ADJSUTED HERE 
                (ACTPCAP(A)+PLANPCAP(A,MODYR)).GT.0.001 ) THEN
            IF  ( CHQAK_ALB.LE.0.001 .OR. &
                  SRC.GT.(DNODES+NXMAPCN) .OR. SRC.LE.(DNODES+3)  )   THEN
              IF (SHR(NET,A,MODYR-1).GE.0.00001) THEN
                SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) *  &
                   ( ACTPCAP(A) + (PLANPCAP(A,MODYR)*PCTADJSHR) ) / ACTPCAP(A)
              ELSE
                ARC_1 = ARC_LOOP(NET,DEST,1)
                ARC_2 = ARC_LOOP(NET,DEST,2)
                TOTFLW = 0.0
                DO A2 = ARC_1,ARC_2
                  TOTFLW = TOTFLW + FLOW(NET,A2)
                ENDDO
                SHR(NET,A,MODYR-1) = (PLANPCAP(A,MODYR)*0.15) / TOTFLW     ! YD1 (REALLY JBE) INITIALIZE LNG IF ZERO
                ARC_SHRPR(NET,A) = NODE_SHRPR(NET,DEST)    
              ENDIF
            ENDIF 
          ENDIF
        ENDDO

        DO DEST=1,DNODES                ! SCALE SO SUM SHARES ADDS TO ONE
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)
          IF (ARC_1 .EQ. ARC_2) THEN         ! SINGLE ARC INTO NODE
            SHR(NET,ARC_1,MODYR-1) = 1.0
          ELSE
            SHRSUM = 0.0
            DO A=ARC_1,ARC_2
              SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)
            ENDDO
            DO A = ARC_1,ARC_2
              SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM
            ENDDO
          ENDIF
        ENDDO

!  ADJUSTMENT IF ANGTS OR MACKENZIE DELTA COME ON

        IF (CHQAK_ALB .GT. 0.0000001) THEN
          TOTFLW = 0.0
          DO I=4,NXMAPUS
            SRC  = CAN_XMAPUS(I,2)
            DEST = CAN_XMAPUS(I,1)
            A = NODE_2ARC(SRC,DEST)
            TOTFLW = TOTFLW + FLOW(NET,A)
          ENDDO
          
                          ! 80 PERCENT INITIAL US VS CANADA DISPLACEMENT        
! EM4 TRACK -- keep here
          FLDEL16 = (FLOW(NET,NODE_2ARC(16,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00
          FLDEL17 = (FLOW(NET,NODE_2ARC(17,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00            
          FLDEL18 = (FLOW(NET,NODE_2ARC(18,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00        
          FLDEL19 = (FLOW(NET,NODE_2ARC(19,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00
          
          DEST = 4
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)
          TOTFLW = 0.0
          SHRSUM = 0.0
          DO A=ARC_1,ARC_2
            SRC =  ARC_2NODE(A,1)
            TOTFLW = TOTFLW + FLOW(NET,A)
            IF (SRC.NE.16 .AND. SRC.NE.17) SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)
          ENDDO
          A16 = NODE_2ARC(16,4)
          SHR(NET,A16,MODYR-1) = ( FLOW(NET,A16) + FLDEL16) / TOTFLW
          SHR(NET,A16,MODYR-1) = AMIN1(SHR(NET,A16,MODYR-1),1.0)
          A17 = NODE_2ARC(17,4)
          SHR(NET,A17,MODYR-1) = ( FLOW(NET,A17) + FLDEL17) / TOTFLW
          SHR(NET,A17,MODYR-1) = AMIN1(SHR(NET,A17,MODYR-1),1.0)
          SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1)
          IF (SHR1617.GT.1.0) THEN
            SHR(NET,A16,MODYR-1) = SHR(NET,A16,MODYR-1) / SHR1617
            SHR(NET,A17,MODYR-1) = SHR(NET,A17,MODYR-1) / SHR1617
            SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1)
          ENDIF
          DO A=ARC_1,ARC_2
            IF (A.NE.A16 .AND. A.NE.A17) THEN
              SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR1617) / SHRSUM
            ENDIF
          ENDDO
        
          DEST = 12
          ARC_1 = ARC_LOOP(NET,DEST,1)
          ARC_2 = ARC_LOOP(NET,DEST,2)
          TOTFLW = 0.0
          SHRSUM = 0.0
          DO A=ARC_1,ARC_2
            SRC =  ARC_2NODE(A,1)
            TOTFLW = TOTFLW + FLOW(NET,A)
            IF (SRC.NE.9) SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)
          ENDDO
          A9 = NODE_2ARC(9,12)            ! INITIAL ASSUME 60 PERCENT ANGTS FLOW THRU FR 9 TO 12
! EM4 TRACK -- keep here
          SHR(NET,A9,MODYR-1) = ( FLOW(NET,A9) + ((FLDEL18+FLDEL19)*1.00) ) / TOTFLW
          SHR(NET,A9,MODYR-1) = AMIN1(SHR(NET,A9,MODYR-1),1.0)
          DO A=ARC_1,ARC_2
            IF (A.NE.A9) THEN
              SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR(NET,A9,MODYR-1)) / SHRSUM
            ENDIF
          ENDDO

        ENDIF
      ENDDO

! ADJUST LAST YEAR'S SHARES IF EXPECTED PRODUCTION BECOMES POSITIVE OR CHANGES SIGNIFICANTLY

      DO SRG =1,NSUPSUB+NOCSREG
        IF (SRG.LE.NSUPSUB) THEN
          PRDEXP = oOGRESNGON(SRG,CURIYR) * oOGPRRNGON(SRG,CURIYR)  ! "Z" ARRAYS NOT SET YET
          PRDEXPLAG = oOGRESNGON(SRG,CURIYR-1) * oOGPRRNGON(SRG,CURIYR-1)
          IF (PRDEXPLAG.GT.0.0) THEN
            PRDCHG = PRDEXP / PRDEXPLAG
          ELSE
            PRDCHG = 1.0
          ENDIF
        ELSE
          ORG = SRG-NSUPSUB
          PRDEXP = oOGRESNGOF(ORG,CURIYR) * oOGPRRNGOF(ORG,CURIYR)  ! "Z" ARRAYS NOT SET YET
          PRDEXPLAG = oOGRESNGOF(ORG,CURIYR-1) * oOGPRRNGOF(ORG,CURIYR-1)
          IF (PRDEXPLAG.GT.0.0) THEN
            PRDCHG = PRDEXP / PRDEXPLAG
          ELSE
            PRDCHG = 1.0
          ENDIF
        ENDIF

        IF ( (PRDEXP.GT.0.00001 .AND. PRDEXPLAG.LE.0.00001) .OR. PRDCHG.GE.1.2 .OR. PRDCHG.LE.0.8) THEN
          DEST = MAP_NG(SRG)
          ASUP = NODE_2ARC(TNODES+SRG,DEST)
          DO NET=1,NETWORK
            TOTFLW = 0.0
            ARC_1 = ARC_LOOP(NET,DEST,1)
            ARC_2 = ARC_LOOP(NET,DEST,2)
            DO A=ARC_1,ARC_2
              TOTFLW = TOTFLW + FLOW(NET,A)
            ENDDO
            SHR(NET,ASUP,MODYR-1) = PRDEXP*SHRYR(NET) / TOTFLW
            SHRSUM = 0.0
            DO A=ARC_1,ARC_2
              SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)
            ENDDO
            DO A=ARC_1,ARC_2
              SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM
            ENDDO
          ENDDO
        ENDIF
      ENDDO

      RETURN
      END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!  WRITE CITYGATE PRICES AND COMPONENTS TO NGODTM DEBUG FILE
!
!  STATUS:  COMPLETE
!
!  CALLED BY:  NGTDM_ITM
!
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

      SUBROUTINE NGDBUG_DTM03(YR)
      IMPLICIT NONE

      include 'parametr'
      include 'ncntrl'
      include 'ngparinc'
      include 'ngitminc'
      include 'ngtdminc'
      include 'ngptmitm'
      include 'nghistinc'
      include 'ogglobal'

      INTEGER*4  NET          ! REPRESENTS PK,OP NETWORK
      INTEGER*4  N,NREG       ! REGION ID
      INTEGER*4  YR           ! HIST/FORE YR FLAG (0=HIST, 1=FORE)
      INTEGER*4  J,I          ! REG COUNTERS
      INTEGER*4  TNET         ! REPRESENTS ANNUAL

      REAL*4     TRES_COM     ! TOTAL RES+COM END_USE DEMAND
      REAL*4     TEND_USE     ! TOTAL END_USE DEMAND
      REAL*4     YRSHR        ! PK/OP DMD SHRS
      REAL*4     YRSHR_F      ! PK/OP UTIL FIRM DMD SHRS
      REAL*4     YRSHR_I      ! PK/OP UTIL INTR DMD SHRS

      REAL*4     TMP_END_USE(DNODES)    ! HOLDS PK END-USE DMDS
      REAL*4     TMP_RES_COM(DNODES)    ! HOLDS PK RES+COM DMDS
      REAL*4     AEND_USE(DNODES)       ! ANNUAL END-USE DMDS
      REAL*4     ACGPR_END_USE(DNODES)  ! ANNUAL CITYGATE PR (WT END-USE)
! ----------

      IF (NGDBGITR(1,3)) THEN
        WRITE(NGODTM,100)
      ENDIF
      DO NET=1,NETWORK
        DO N=1,DNODES

          TRES_COM = 0.0
          TEND_USE = 0.0
          DO I=1,DSEC-1
            IF (NET .EQ. PKNET) THEN
              YRSHR = PKSHR_DMD(I,N)
             ELSE
              YRSHR = 1.-PKSHR_DMD(I,N)
            ENDIF
            TEND_USE = TEND_USE+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N))
            IF (I.EQ.1 .OR. I.EQ.2) THEN
              TRES_COM = TRES_COM+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N))
            ENDIF
          ENDDO
          DO J=1,NNGEM-1
            NREG=EMMSUB_NG(J)
            IF (NREG .EQ. N) THEN
              IF (NET .EQ. PKNET) THEN
                YRSHR_F = PKSHR_UDMD_F(J)
                YRSHR_I = PKSHR_UDMD_I(J)
               ELSE
                YRSHR_F = 1. - PKSHR_UDMD_F(J)
                YRSHR_I = 1. - PKSHR_UDMD_I(J)
              ENDIF
              TEND_USE = TEND_USE + (YRSHR_F* ZNGUQTY_F(J)) + &
                                    (YRSHR_I* ZNGUQTY_I(J))
            ENDIF
          ENDDO

          IF (NGDBGITR(1,3)) THEN
           IF (YR.EQ.0) THEN        ! HISTORICAL YEAR
            WRITE(NGODTM,110) MODYR,CURITR, NET, N, &
              HCGPR(NET,N,MODYR), NODE_ENDPR(NET,N), &
              INTRAREG_TAR(NET,N), INTRAST_TAR(N), &
              CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), &
              TEND_USE, TRES_COM
           ELSE                     ! FORECAST YEAR
            WRITE(NGODTM,110) MODYR,CURITR, NET, N, &
              CGPR(NET,N), NODE_ENDPR(NET,N), &
              INTRAREG_TAR(NET,N), INTRAST_TAR(N), &
              CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), &
              TEND_USE, TRES_COM
           ENDIF
          ENDIF

          IF (NET .EQ. PKNET) THEN
            TMP_END_USE(N) = TEND_USE
            TMP_RES_COM(N) = TRES_COM
          ELSE
            IF (YR.EQ.0) THEN      ! HISTORICAL YEAR
              AEND_USE(N) = TMP_END_USE(N) + TEND_USE
              ACGPR_END_USE(N) = ((HCGPR(PKNET,N,MODYR)*TMP_END_USE(N))+ &
                          (HCGPR(OPNET,N,MODYR)*TEND_USE)) / AEND_USE(N)
              oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM
              oACGPR_RESCOM(N,CURIYR) = ((HCGPR(PKNET,N,MODYR)*TMP_RES_COM(N))+ &
                          (HCGPR(OPNET,N,MODYR)*TRES_COM)) / oARESCOM(N,CURIYR)
            ELSE                   ! FORECAST YEAR
              AEND_USE(N) = TMP_END_USE(N) + TEND_USE
              ACGPR_END_USE(N) = ((CGPR(PKNET,N)*TMP_END_USE(N)) + &
                          (CGPR(OPNET,N)*TEND_USE)) / AEND_USE(N)
              oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM
              oACGPR_RESCOM(N,CURIYR) = ((CGPR(PKNET,N)*TMP_RES_COM(N)) + &
                          (CGPR(OPNET,N)*TRES_COM)) / oARESCOM(N,CURIYR)
            ENDIF
            AVG_CGPR(N,MODYR) = ACGPR_END_USE(N)
          ENDIF

        ENDDO
      ENDDO

! PUT INTO REPORT VARIABLES NGCGPR(REG,YR), NGNODDMD(REG,YR), NGENDDMD(REG,YR)
! NOTE: 'REGIONS' 13,14,15 ARE CDs 5,8,9 (for reporting)

      DO N=1,DNODES
        NGNODDMD(N,CURIYR) = 0.0

        NGCGPR(N,CURIYR) = ACGPR_END_USE(N)
        NGENDDMD(N,CURIYR) = AEND_USE(N)
        DO NET=1,NETWORK
          NGNODDMD(N,CURIYR) = NGNODDMD(N,CURIYR) + &
                               NODE_DMD(NET,N)
        ENDDO

        IF (N .EQ. 5) THEN                ! combine ngreg 5&10 into CD 5
          NGCGPR(DNODES+1,CURIYR) = ( (ACGPR_END_USE(10)*AEND_USE(10)) + &
                                      (ACGPR_END_USE(N) *AEND_USE(N))) / &
                                      (AEND_USE(10) + AEND_USE(N))
          NGENDDMD(DNODES+1,CURIYR) =  AEND_USE(10) + AEND_USE(N)
          NGNODDMD(DNODES+1,CURIYR) = 0.0
          DO NET=1,NETWORK
            NGNODDMD(DNODES+1,CURIYR) = NGNODDMD(DNODES+1,CURIYR) + &
                                 NODE_DMD(NET,10) + NODE_DMD(NET,N)
          ENDDO
        ELSE IF (N .EQ. 8) THEN           ! combine ngreg 8&11 into CD 8
          NGCGPR(DNODES+2,CURIYR) = ( (ACGPR_END_USE(11)*AEND_USE(11)) + &
                               (ACGPR_END_USE(N) *AEND_USE(N))) / &
                               (AEND_USE(11) + AEND_USE(N))
          NGENDDMD(DNODES+2,CURIYR) =  AEND_USE(11) + AEND_USE(N)
          NGNODDMD(DNODES+2,CURIYR) = 0.0
          DO NET=1,NETWORK
            NGNODDMD(DNODES+2,CURIYR) = NGNODDMD(DNODES+2,CURIYR) + &
                                 NODE_DMD(NET,11) + NODE_DMD(NET,N)
          ENDDO
        ELSE IF (N .EQ. 9) THEN           ! combine ngreg 9&12 into CD 9
          NGCGPR(DNODES+3,CURIYR) = ( (ACGPR_END_USE(12)*AEND_USE(12)) + &
                               (ACGPR_END_USE(N) *AEND_USE(N))) / &
                               (AEND_USE(12) + AEND_USE(N))
          NGENDDMD(DNODES+3,CURIYR) =  AEND_USE(12) + AEND_USE(N)
          NGNODDMD(DNODES+3,CURIYR) = 0.0
          DO NET=1,NETWORK
            NGNODDMD(DNODES+3,CURIYR) = NGNODDMD(DNODES+3,CURIYR) + &
                                 NODE_DMD(NET,12) + NODE_DMD(NET,N)
          ENDDO
        ENDIF
      ENDDO

      IF (NGDBGITR(1,3)) THEN
        WRITE(NGODTM,120)
        DO N=1,DNODES
          TNET = 0
          WRITE(NGODTM,130) MODYR,CURITR, TNET, N, &
            ACGPR_END_USE(N), AEND_USE(N), &
            oACGPR_RESCOM(N,CURIYR), oARESCOM(N,CURIYR)
        ENDDO
      ENDIF

  100 FORMAT(1X,'DTM03: YEAR ITR NET NOD   CGPRICE = NODEPR + ', &
        'INTRAREG + INTRAST + CGBENCH     INTRA_FLO   END_USE_DMD', &
        '   RES+COM_DMD')
  110 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3, &
        F10.3,3F14.1)

  120 FORMAT(1X,'DTM03: YEAR ITR NET NOD  CGPR_END  QEND_USE ', &
        ' CGPR_R+C  QRES+COM')
  130 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3)

      RETURN
      END