! $Header: m:/default/source/RCS/ngitm.f,v 1.125 2011/01/14 22:32: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

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

!

! 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 -orFLORIDA

 ! 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 'udatout'

 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 ! 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

 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_TIGHT(17)

 REAL*4 U_PROD_SHALE(17)

 REAL*4 U_PROD_CBM(17)

 REAL*4 NG_REDUCT

 REAL*4 NG_REDUCT_NEW

 REAL*4 NG_REDUCT_EXIST 

 REAL*4 TIGHT_WELLS_TOT

 REAL*4 SHALE_WELLS_TOT

 REAL*4 CBM_WELLS_TOT

 REAL*4 NG_REDUCT_WELL
! 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.8

73371,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,curiyr1)+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

 

 

 

 IF (IREG.LE.17) THEN

 

 ! EPA CODE MODIFICATION FOR RIA 03/31/12

 ! PER NEW HF GAS WELL COMPLETION GAS CAPTURE BY REC PER WELL (IN 

BCF) (BASELINE = 0.00000; FINAL RULE = 0.002473)

 ! PLEASE SEE REGULATORY IMPACT ANALYSIS OF FINAL RULE FOR DETAILS

 

 NG_REDUCT_WELL = 0.002473 !IN BILLION CUBIC FEET PER WELL

 

 ! NUMBER OF SUCCESSFUL WELLS OF EACH TYPE

 TIGHT_WELLS_TOT = oSUCWELLL48(1,1,5)+oSUCWELLL48(2,1,5)+ 

oSUCWELLL48(1,2,5)+ oSUCWELLL48(2,2,5) &

 + oSUCWELLL48(1,3,5) + oSUCWELLL48(2,3,5) + oSUCWELLL48(1,4,5)+ 

oSUCWELLL48(2,4,5) &

 + oSUCWELLL48(1,5,5) + oSUCWELLL48(2,5,5) + oSUCWELLL48(1,6,5)+ 

oSUCWELLL48(2,6,5) 

 

 SHALE_WELLS_TOT = oSUCWELLL48(1,1,6)+oSUCWELLL48(2,1,6)+ 

oSUCWELLL48(1,2,6)+ oSUCWELLL48(2,2,6) &

 + oSUCWELLL48(1,3,6) + oSUCWELLL48(2,3,6) + oSUCWELLL48(1,4,6) + 

oSUCWELLL48(2,4,6) &

 + oSUCWELLL48(1,5,6) + oSUCWELLL48(2,5,6) + oSUCWELLL48(1,6,6) + 

oSUCWELLL48(2,6,6) 

 CBM_WELLS_TOT = oSUCWELLL48(1,1,7) + oSUCWELLL48(2,1,7)+ 

oSUCWELLL48(1,2,7)+oSUCWELLL48(2,2,7) &

 + oSUCWELLL48(1,3,7) + oSUCWELLL48(2,3,7) + oSUCWELLL48(1,4,7) + 

oSUCWELLL48(2,4,7) &

 + oSUCWELLL48(1,5,7) + oSUCWELLL48(2,5,7) + oSUCWELLL48(1,6,7) + 

oSUCWELLL48(2,6,7) 

 ! DISTRIBUTION OF PRODUCTION BY TYPE AND REGION, ESTIMATED BASED ON 

AEO2011 REFERENCE CASE MODEL

U_PROD_TIGHT(1) = 0.0000

U_PROD_TIGHT(2) = 0.0107

U_PROD_TIGHT(3) = 0.0048

U_PROD_TIGHT(4) = 0.0000

U_PROD_TIGHT(5) = 0.0000

U_PROD_TIGHT(6) = 0.0000

U_PROD_TIGHT(7) = 0.0000

U_PROD_TIGHT(8) = 0.0002

U_PROD_TIGHT(9) = 0.2074

U_PROD_TIGHT(10) = 0.0842

U_PROD_TIGHT(11) = 0.1382

U_PROD_TIGHT(12) = 0.4064

U_PROD_TIGHT(13) = 0.0000

U_PROD_TIGHT(14) = 0.0000

U_PROD_TIGHT(15) = 0.0130
U_PROD_TIGHT(16) = 0.1351

U_PROD_TIGHT(17) = 0.0000

U_PROD_SHALE(1) = 0.0000

U_PROD_SHALE(2) = 0.2712

U_PROD_SHALE(3) = 0.0307

U_PROD_SHALE(4) = 0.0000

U_PROD_SHALE(5) = 0.0000

U_PROD_SHALE(6) = 0.0602

U_PROD_SHALE(7) = 0.0000

U_PROD_SHALE(8) = 0.0000

U_PROD_SHALE(9) = 0.1964

U_PROD_SHALE(10) = 0.1856

U_PROD_SHALE(11) = 0.2380

U_PROD_SHALE(12) = 0.0058

U_PROD_SHALE(13) = 0.0000

U_PROD_SHALE(14) = 0.0000

U_PROD_SHALE(15) = 0.0000

U_PROD_SHALE(16) = 0.0121

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.0386

U_PROD_CBM(5) = 0.0000

U_PROD_CBM(6) = 0.0007

U_PROD_CBM(7) = 0.0000

U_PROD_CBM(8) = 0.0850

U_PROD_CBM(9) = 0.0009

U_PROD_CBM(10) = 0.0007

U_PROD_CBM(11) = 0.0174

U_PROD_CBM(12) = 0.8566

U_PROD_CBM(13) = 0.0000

U_PROD_CBM(14) = 0.0000

U_PROD_CBM(15) = 0.0000

U_PROD_CBM(16) = 0.0000

U_PROD_CBM(17) = 0.0000

! DISTRIBUTES ESTIMATES OF CAPTURED GAS ACROSS WELL TYPES AND 

REGION

! THE (0.36) ACCOUNTS FOR RECS ON NEW HF GAS WELLS THAT ARE 

REQUIRED, EXCEPT FOR THE FOLLOWING WHICH ARE ASSUMED TO ALREADY BE IN THE 

DATA:

 ! STATES WHERE ALREADY REQUIRED

 ! LOW PRESSURE WELLS

 ! VOLUNTARY ACTIVITIES

 ! FOR RECS ON NEW HF GAS WELLS WELLS

NG_REDUCT_NEW = 0

NG_REDUCT_NEW = (0.36) * (NG_REDUCT_WELL * TIGHT_WELLS_TOT * 

U_PROD_TIGHT(IREG) &

 + NG_REDUCT_WELL * SHALE_WELLS_TOT 

* U_PROD_SHALE(IREG) &
 + NG_REDUCT_WELL * CBM_WELLS_TOT * 

U_PROD_CBM(IREG))

 

 ! ADDS NATURAL GAS RECOVERED BE FOR RECS ON ALREADY EXISTING HF GAS 

WELLS WELLS

 ! DISTRIBUTES ESTIMATES OF RECOVER ACROSS FORMATION TYPES

! THIS PART ALREADY ACCOUNTS FOR ACTIVITIES IN ABSENSE OF 

REGULATION

NG_REDUCT_EXIST = 0 

NG_REDUCT_EXIST = (1.3603 * U_PROD_TIGHT(IREG)) + (1.6624 * 

U_PROD_SHALE(IREG)) + (0.3856 * U_PROD_CBM(IREG)) 

 

 XQBASE = NG_REDUCT_NEW + NG_REDUCT_EXIST + XQBASE

 

 ENDIF

 ENDIF

! XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))

 IF (MODYR.LE.EHISYR .OR. SUPCRV.EQ.1) THEN

 XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG))

 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,curiyr1)**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,curiyr1)**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.1E03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))

 ELSE

 XPBASE = 0.66 + (0.75*ZWPRLAG(IREG)) - ZOGTAXPREM(IREG)

 ENDIF

 ELSE

 XPBASE = ZWPRLAG(IREG) - ZOGTAXPREM(IREG) - 0.1E03*(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

 ELSE ! from 

ngptmX.f

 ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & ! from 

ngptmX.f

 NGPIPE_VARTAR(NET,A,Q)

 ENDIF ! from 

ngptmX.f

 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

 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

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

 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)

 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,MODY

R),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)

 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)) ) / &

 (BASQ_TRFV_SF(NET,N) + BASQ_TRPV_SF(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)

 NGUPR_SF(NET,J) = CGPR(NET,N) + UDTAR_SF(NET,J)

 NGUPR_SI(NET,J) = CGPR(NET,N) + UDTAR_SI(NET,J)

! 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)

 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)

! 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)) ) / &

(BASQ_TRFV_F(N) + BASQ_TRPV_F(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 'ogglobal'

 INTEGER*4 L,A ! COUNTERS

 INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

 INTEGER*4 N ! 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

 

!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) 

 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)

 ! 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) )) 

 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) ))

 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 ! 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 .LE. EHISYR) .AND. (MODYR .NE. IBASYR)) THEN

 ZWPRLAG(I) = HPSUP(I,MODYR)

!CCC ZWPRLAG(I) = HPSUP(I,MODYR-1)

 ELSE

 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 .LE. EHISYR) .AND. (MODYR .NE. IBASYR)) THEN

 ZWPRLAG(I) = HPSUP(I,MODYR)

!CCC ZWPRLAG(I) = HPSUP(I,MODYR-1)

 ELSE

 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 .LE. EHISYR) .AND. (MODYR .NE. IBASYR)) THEN

 ZWPRLAG(SNODES-lSNODES-3) = HPSUP(SNODES-lSNODES-3,MODYR)

!CCC ZWPRLAG(SNODES-lSNODES-3) = HPSUP(SNODES-lSNODES-3,MODYR-1)

 ELSE

 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) T

 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=',I3,11X,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