! $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_S UPPR ! 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 CURV E 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 !utzSRC = 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) = PAR M_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_SHR PR(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) THE N

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,NPROCDEST = 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 USI NG 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 (C NVGFLG .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 A RC 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) = HPPERJ AN(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,DNODESWRITE (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

NG QTY_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) * NCPE RMTH(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 monthMTH_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 = oOGQNG IMP(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) * ADJFIXSUPIP(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) = MT H_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
!
! STA TUS: 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 ! tempENDIF

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

PFUE L(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 SUP PLY 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) the n ! temp GAMMAFAC = 1.0 ! temp CALL NGSHR_CALC(DEST,NET) ! temp else ! temp GAMMAFAC = GAMMATMP ! tempCALL Z2NGS HR_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) ! t emp 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)

NOD E_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A) IF ((NET.EQ.PKNET) .AND. (SRC.GT.(TNODES+SNODES))) THENNODE_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 NETWORKINTEGER*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 ! NUM BER 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 ! T OTAL 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)) THE N ! 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(NE T,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) = 1ELSEIF (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(N ET,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)) THENSHR(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
SUM MAX = 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 SHARESBKSTOP(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 ALO NG 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 CAPNGSET_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(N ET,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 NO DE ! ! 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 FLG FLOW(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

AR C_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_SHR PR(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))**GAMM AFAC) / &

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

IN TEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOPREAL*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) ! M AXIMUM 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_LOO P(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
ELSEPRV_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 ! L OOP 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 C UR_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) *P KUTZ(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_E FFCAP(NET,A)

- PRVFLOW(NET,A)) ** &

ALPHAFAC
ELSE PRV_REMCAP(A) = 0.0ENDIF 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))

EN DIF
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 COUNTERSINTEGER*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 VARI ABLE 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_PCTFL O, &

"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

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

ENDDOIF (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, C YCLE

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 NODEINTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATIN G 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(AR CS) ! 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(NGOE RR,*) " 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 ca p 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 ! L OOP 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

FLGST OP = 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) THENFLOWNEG = 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) TH EN
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

IN TEGER*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 = AR C_LOOP(NET,DEST,2) ! X INVPR_SUM = 0.0 ! X
! X IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO N ODE ! X SHR(NET,ARC_1,MODYR) = 1.0 ! X
ELSE ! X DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ! X IF (ARC_SHRP R(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 FLO WS
!
! 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 NETWORKINTEGER*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 ADDITIONSTMTH_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(N ET,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 = M TH_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

- TNO DES)) !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 * (NE W_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 * M AXPCAP(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_RED C) * &(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,' MT HSTR= ',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_S TR= ",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 = A RC_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

M TH_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 annua l 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 AR CS 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_FLWCHNG = 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 ! NUM BER 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 ARCSSRC = 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
ENDDOELSE
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 O F 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 SHRREAL*4 NGSET_MAXFLO ! FU NCTION: 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) ! SH ARES 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 ARCSIF (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 !utzSRC = 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

MAXPCA P(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)

I MPLICIT NONE

include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK
INTEGER*4 A ! COUNTERINTEGER*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. P KNET) THEN ! PEAK

XNGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC
ELSE ! OFFPEAK IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR. & ((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN ! SUPPLY

- or

FLORIDA
! NO CURPCAP FOR SUPPLY

MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A) ! storage, imports, or nobldyr

ELSE
XCAP = FL OW(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
!xutz60 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
ENDDODO 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

CAL L 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 O VER 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

ENDIFENDDO
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, S ET 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)

ENDIFENDDO
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 ! ANNU AL 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 TO TQ(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) + 1IF (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 = ANNS UP + 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 = AN NSUP + 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 FUNC TION (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
S H = 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

I F ((TOTQ(PKNET,M)+TOTQ(OPNET,M)).GT.0.0) THENPSUP(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)

INT EGER*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 POINTREAL*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 FI XSUP ! "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 C ONSTRANTS 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 he re 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.000 000,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.69 612,

- 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.3013 1,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 SHAREIF (MODYR.GT.EHISYR) THEN L48_PRD = (oogqngrep(1,curiyr

- 1) + oogqngrep(2,curiyr

- 1) +

o ogqngrep(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,cur iyr

- 1) + oogqngrep(2,curiyr

- 1) + oogqngrep(3,curiyr

- 1)) &

/ L48_PRD onconvSHR = oogqngrep(4,curiyr

- 1) / L48_PRD UGRRESSHRLAG = (oOGNGRSV(1,curiyr

- 1)+oOGNGRSV(2,curiyr

1)+oOGNGRSV(3,curiyr

- 1)) & / (oOGNGRSV(9,curiyr

- 1)) * 100.

UGRRESSHR = (oOGNGRSV(1,curiyr)+oOGNGRSV(2,curiyr)+oOGNGRSV(3,curiyr)) & / (oOGNGRSV(9,curiyr)) * 100.

IF (MODYR.EQ.EHISYR+1) THEN
HDDLAG = 4524 ! HDD from 9/2009

STEO
HDD = 4475. ! OEXSPEND(1,curiyr) = 1288. ! OEXSPEND(2,curiyr) = 67555752. ELSEIF (MODYR.EQ.EHISYR+2) THEN

HDDLAG = HDD
HDD = 4478. ! OEXSPEND(1,curiyr) = 1204. ! OEXSPEND(2,curiyr) = 59013208.

ELSE
HDDLAG = HDD
HDD = 4237.

ENDIF

ELSE
REPRATE = 0.
UGRSHR = 0.

ENDIF

! SET VARIABLES WHICH DON'T CHANGE BASED ON VALUE COMING IN

! NREG = NG_NREG(IREG) ! FUNCTION MAPPING

SUP ID TO NG ID IVREG=VNODES(IREG) NREG = MAP_NG(IREG) IF(IREG.EQ.SNODES

- lSNODES

- 3) NREG=13 PERCNT = PCTLP(NREG) * SCALE_LP(MODYR)

IF (MODYR .LE. EHISYR) THENXQBASE = 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

! NU MBER 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) +

o SUCWELLL48(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 BAS ED 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.0130U_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_RE DUCT_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,curiyr

1)**0.066852 * HDD**2.22467 &

* ZWPRLAG(IREG)**0.527302 * exp(

- 24.2580*(

- 0.527302)) *

UGRRES SHRLAG**(

- 0.527302*1.62970) &

* oEXSPEND(1,curiyr

- 2)**(

- 0.527302*0.066852) * HDD**(

- 0.527302*2.22467) ELSEIF (SUPCRV.EQ.5) THEN XPBASE = exp(

- 16.4735) * UGRRESSHR**1.16172 * oEXSPEND(1,curiyr

1)**0.072937 * HDD**1.49735 &

* ZWPRLAG(IREG)**0.317304 * exp(

- 16.4735*(

- 0.317304)) * UGRRESSHRLAG**(

- 0.317304*1.16172) &

* oEXSPEND(1,curiyr

- 2)**(

- 0.317304*0.072937) * HDD**(

- 0.317304*1.49735) ELSEIF (SUPCRV.EQ.6) THEN ! AEO2010 if (zogresng( ireg).gt.0.) THEN
A1 =

- 10.6700 ! constant
B4 =

- 0.014253 ! BOY res B1 = 0.633804 ! ugrresshr B2 = 0.190494 ! average drill cost
B3 = 0.882912 ! HDD
B5 = 0.279016 ! WOP

RHO = 0.398350 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 *
HDD**B3 & * ZOGRESNG(IREG)**(B4) &

* oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(

- RHO)) * UGRRESSHRLAG**(

- RHO*B1) & * (oEXSPEND(1,curiyr

- 1))**(

- RHO*B2) * HDDLAG**(

- RHO*B3) &* ZOGRESNGLAG1(IREG)**(

- RHO*B4) & * oIT_WOP(CURIYR

- 1,1)**(

- RHO*B5) &
* 1.00000

ELSE XPBASE = (ZWPRLAG(IREG)

- ZOGTAXPREM(IREG))

ENDIF ELSEIF (SUPCRV.EQ.7) THEN if (zogresng(ireg).gt.0.) THEN
A1 =

- 0.298040 ! constant
B4 = 0. ! BOY res B1 = 0. ! ugrresshr B2 = 0.403666 ! average cost per mcf
B3 = 0. ! HDD
B5 = 0.311518 ! WOP
RHO = 0.504134 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 *
HDD**B3 & * ZOGRESNG(IREG)**(B4) &

* oIT_WOP(CURIYR,1)**B 5 * 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) * HDD LAG**(

- 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 mcfB3 = 0. ! HDD
B5 = 0. ! WOP
RHO = 0.379721 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 *
HDD**B3 & * ZOGRESNG(IREG)**(B4) &

* oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(

- RHO)) * UGRRESSHRLAG**(

- RHO*B1) & * (oEXSPEND(3,curiyr

- 1))**(

- RHO*B2) * HDDLAG**(

- RHO*B3) & * ZOGRESNGLAG1(IREG)**(

- RHO*B4) & * oIT_WOP(CURIYR

- 1,1)**(

- RHO*B5) &
* 1.02188

ELSE XPBASE = (ZWPRLAG(IREG)

- ZOGTAXPREM(IREG))

ENDIF ELSEIF (SUPCRV.EQ.21) THEN IF (MODYR.LE.2006) THEN ! steo? IF (SUPTYPE(IREG).LE.9) THEN XPBASE = 0.95*ZWPRLAG(IREG)

- ZOGTAXPREM(IREG)

- 0.1E

03*(ZOG RESNG(IREG)

- ZOGRESNGLAG1(IREG))

ELSE XPBASE = 0.66 + (0.75*ZWPRLAG(IREG))

- ZOGTAXPREM(IREG)

ENDIF
ELSE XPBASE = ZWPRLAG(IREG)

- ZOGTAXPREM(IREG)

- 0.1E

03*(ZOGRESNG(IREG)

- ZOGRESNGLAG1(IREG))

IF (SUPTYPE(IREG).GT.9) XPBASE = 0.36 + (0.85*ZWPRLAG(IREG))

- ZOGTAXPREM(IREG)

ENDIF

ELSEIF (SUPCRV.EQ.8) THEN XPBASE = exp(

- 2.88475) * UGRRESSHR**0.749417 * oIT_WOP(CURIYR,1)**0.325610 &

* ZWPRLAG(IREG)**0.339 752 * 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_W OP(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,CU RIYR

- 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.277 866 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 ty pe 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 IFNGSUP_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

- FI XSUP+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) THENIF (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_CNS T2(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,*) ' '

ENDIFIF (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,' V ALUE=',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 NG SET_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 NONEinclude '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 f or 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)) THE N 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)) THENXNGPIPE_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

XNGPIP E_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 = (.14 2/ 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
! XNG PIPE_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 XNGST R_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
!

-------------

XNG STR_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 'ngpa rinc' 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 LOSSREAL*4 TARCPQ,TARCQ ! HOLDS TOT USED TO AVG PR

!

-------------

DO L=NPROC,1,

- 1 ! MOVE UP TRE E 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) THENSHR_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,DE ST)

- 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)
! NOD E_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 NGP IPE_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(O PNET,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,DES T,MODYR),SAFLOW(A,MODY R),NODE_DMD(NET,DEST),PFUEL(NET,DEST)

ELSEA = 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 = INT RAREG_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

ENDD O

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 AVER AGE 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) ! P R * 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 NONUTILI TY 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)

ENDD O
! 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_S F(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 SECTORSDO 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) + BAS UQTY_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 NGSTE O_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_T RPV_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) * B ASQ_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 REGIO NS 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

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
! RE SET 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

ENDDODO 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 CUR ITR=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 ! S UBREGION 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: NG TDM_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)

ELSEIF (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),MAXPC AP17)

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 ITER ATION ! 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 ISLANDIF (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,CU RIYR) !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
!
! ST ATUS: 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
! <>oth er 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 ! >discrepanc y !
!================================================================== 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 CROSSINGREAL*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 supplyELSE 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))

E NDIF
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 * ZT OTSUP(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) * PPER MTH(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) CAL L 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,1 8.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,MOD YR) * (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 REPROD UCE 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 SUPPLEME NTAL !
! 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) ot her 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 LIQUI DS 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 S UPPLY 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.1 0) 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 'ng cdmdinc' 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)*SC ALE_LP(MODYR)))

ENDDO

ENDIF

RETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
! PUT OGSM VARIABLES INTO NG ZOG... VARIABLES
! ZOGRESNG
! ZOGPRRNG
! ZOGCCAPPRD
! ZOGTAXPREM
!
! STATUS: PLA CEHOLDER
! ! 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) = oOGRA DNGOF(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) = oO GPRRNGOF(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
ENDDOIF (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(SNO DES

- 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

ZWP RLAG(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 ! F UNCTION: 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,pk net,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)
!JBEMAXELSE 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 I F (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(PKN ET,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(SI D) *

& 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(PKNE T,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
ENDDORETURN

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

INTE GER*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) THENK=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

END IF

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 'n gitminc'

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 ! REPRES ENTS 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 T O 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) THENOUTID = '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)

C NV(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, M ODYR, 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

ENDIFENDDO

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)

I NTEGER*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 A RC

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 (NCR L .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(OUTP UT,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 COUNTERSINTEGER*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'
i nclude '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 ! TO TAL 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 INF O: 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 = FL OW(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, PKSHENDDO
ENDDO

WRITE(OUTPUT,*) ' XXX SECONDARY CAPACITY' WRITE(OUTP UT,*) ' 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,8F1 0.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_SU PPR ! 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_ITMIMPLICIT 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 = SNOD E_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,MO DYR) = 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_CD MD(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)

H BAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR)

- DEL_DISCR4(MODYR) ELSE IF (MODYR .EQ. LHISYR) THENDO 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,NLN GTER

- 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,DN ODES
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 OFFP EAK DISCREPANCY OVER REGIONS, BY ADJUSTING
! ANNUAL REGIONAL DISCREPANCYPKADJ = ((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 ONLYTPFLOW(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 PIPEREAL*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,DE ST) = 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_DM D(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.0ENDIF 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 H AFLOWS 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_2SRC = 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_2SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN FLOW(NET0,A) = HAFLOW(A,MODYR)

- FLOW(NET,A)

ENDIF
ENDDO

EN DIF

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_L OOP(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 (S RC.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(NE T,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'
inc lude '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(NETWOR K,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_2SRC = 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 'n gitminc' 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 SH R

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 ! M AXIMUM 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 E LSE 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 ARCSIF (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 NE T,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

N ODE_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_PSUP PREV(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 ! RE PRESENTS 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

INT EGER*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 TH IS 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 INCREASECHQAK_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.0DO 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.N E.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_2SRC = 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,1 2) ! 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_2TOTFLW = 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'
i nclude '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 DMDSREAL*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) THENTMP_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) + TR ES_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) = ( (ACG PR_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)

NGNOD DMD(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)

ENDDOELSE 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 = NOD EPR + ', & '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