! $Header: m:/default/source/RCS/ngitm.f,v 1.142 2013/10/21 21:27:38 JBE Exp $

! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! NEW INTERSTATE TRANSMISSION MODULE (ITM) FOR THE NGTDM ! ! 01/02/97 SPLIT FROM PREPROCESSING PORTION, PUT INTO NGTDM ! ! STATUS: ! ! CALLED BY: NGMAIN ! ! CALLS: NGITM_PRE ! PREPROCESSOR ! NGSET_NODEDMD ! SET NET DMDS ! NGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS ! NGSET_SUPPR ! SET SUPPLY PR USING CURVE ! NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS ! NGSET_STORPR ! SET STORAGE PRICE ! NGUP_TREE(NET) ! SET NODE PRICE ! NGSET_SECPR ! SET END-USE SECTOR PRICES ! NGCHK_CONVNG ! CHECK CONVERGENCE UP/DOWN TREE ! NGSET_PREV ! SET PREV SUP/DMD FOR CONV CHK NXT CYC ! NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ ! NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! SUBROUTINE NGTDM_ITM IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc' include 'nghistinc' include 'ngptmitm'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 DEST,N ! REGION ID INTEGER*4 A ! ARC ID

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 SRC ! NODE ID INTEGER*4 L,STID ! COUNTER ! --------------

!!! TEMP: SET PIPELINE UTILIZATIONS TO 1 AFTER HIST YEARS IF (MODYR .GT. NOBLDYR) THEN !utz DO A=1,NARCS !utz SRC = ARC_2NODE(A,1) !utz !utz IF (SRC .LE. TNODES) THEN !utz PKUTZ(A) = 1.0 !utz OPUTZ(A) = 1.0 !utz ENDIF !utz ENDDO !utz ENDIF !utz

CALL NGITM_PRE ! PREPROCESSING FOR THE ITM ! - SET CONST DMD ! - SET MAX CAPACITY

! IF (CURITR.EQ.1 .AND. MODYR.GE.2011 .AND. MODYR.LE.2018) THEN ! PARM_SUPELAS(1) = PARM_SUPELAS(1) + 0.0375! PARM_SUPELAS(2) = PARM_SUPELAS(2) + 0.03125 ! PARM_SUPELAS(3) = PARM_SUPELAS(3) + 0.025 ! PARM_SUPELAS(4) = PARM_SUPELAS(4) + 0.01875 ! PARM_SUPELAS(5) = PARM_SUPELAS(5) + 0.0 ! ENDIF ! SET ARC_SHRPR TO T-1 LEVEL EACH NEMS ITERATION DO NET=1,NETWORK DO A=1,NARCS ARC_SHRPR(NET,A) = ARC_PREV_SHRPR(NET,A) ENDDO ENDDO

! SET RBKSTOP_PADJ TO 0.0 1ST NEMS ITR DO NET=1,NETWORK DO DEST=1,TNODES RBKSTOP_FLG(NET,DEST) = -1 BKSTOP_PADJ(NET,DEST) = 0.1 !EM4 IF (CURITR .EQ. 1) THEN

RBKSTOP_PADJ(NET,DEST) = 0.0 !CCC RBKSTOP_PADJ(NET,DEST) = 0.5 * RBKSTOP_PADJ(NET,DEST) !EM4 ENDIF

ENDDO ENDDO

! CYCLE UP & DOWN NETWORK TREE

CYCLE = 1 ! BEGIN CYCLE AT 1 CNVGFLG = 0 DO WHILE ((CNVGFLG .EQ. 0) .AND. (CYCLE .LE. MAXCYCLE))

CALL NGSET_NODEDMD ! SPLIT F/I INTO P/O; ADD CONST DMD

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN IF ((CYCLE .EQ. 1) .AND. (CURITR .EQ. 1)) THEN CALL NGHIST_DISCR ENDIF

! ADD HISTORICAL NET INJECTIONS TO NODE_DMD ON OP NETWORK

DO L=1,NPROC DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2)

! ADD NET INJECTIONS TO OFFPEAK DMDS DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .GT. (TNODES+SNODES)) THEN STID = SRC - (TNODES+SNODES) NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + & HNETINJ(STID,MODYR) - HNETWTH(STID,MODYR) ENDIF ENDDO ENDDO ENDIF

DO NET=1,NETWORK CALL NGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS ENDDO

! IF (MODYR .LE. LHISYR) THEN ! CALL HNGSET_SUPPR ! SET HIST SUPPLY, FLOWS BY SEASON ! else ! CALL NGCHK_CONVNG ! CHECK UP/DOWN TREE CONV USING SUP PROD ! endif

CALL NGCHK_CONVNG ! CHECK UP/DOWN TREE CONV USING SUP PROD! AND SET SUPPLY PR USING CURVE

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN IF (CNVGFLG .EQ. 1) THEN CALL HNGSET_SUPPR ! SET HIST SUPPLY, FLOWS BY SEASON ENDIF ENDIF

CALL NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

DO NET=NETWORK,1,-1 ! SET NODE & STORAGE PR IF (NET .EQ. PKNET) CALL NGSET_STORPR CALL NGUP_TREE(NET) ENDDO

CALL NGSET_INTRAFLO ! SET INTRAREGIONAL FLOWS & CAPACITIES ! (AND FOR LHISYR, ! SET CITYGATE PRICES AND BENCHMARK FAC)

CALL NGSET_SECPR ! SET END-USE SECTOR PRICES

CALL NGSET_PREV ! SET PREV SUP/DMD FOR CONV CHK NXT CYC

! DEBUG REPORTS IF (NGDBGITR(4,2)) THEN CALL NGITM_DEBUG2(NGOTREE) CALL NGITM_DEBUG3(NGOTREE) ENDIF

IF (NGDBGITR(4,1)) THEN CALL NGITM_DEBUG7(NGOBAL) ENDIF

CYCLE = CYCLE+1 ENDDO

IF (CNVGFLG .EQ. 0) THEN WRITE(NGOERR,*) 'NOT CONVERGED ON CYCLE= ',MAXCYCLE, & ' ITR= ',CURITR,' YEAR= ',MODYR, ' ! ATTN4' ENDIF

CALL NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ CALL NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

IF (NGDBGITR(4,11)) THEN CALL NGITM_DEBUG7(NGOBAL) ENDIF

IF (NGDBGITR(4,12)) THEN CALL NGITM_DEBUG2(NGOTREE) CALL NGITM_DEBUG3(NGOTREE) ENDIF

CALL NGDBUG_DTM03(1)

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET NET NODE DEMANDS USING END-USE AND CONST DEMANDS ! NODE_DMD ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM !! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGSET_NODEDMD IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'nghistinc' include 'ogglobal'

INTEGER*4 A,J,L,I ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 ST ! STORAGE NODE ID (1-14) INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 N ! NODE ID INTEGER*4 SEC ! SECTOR ID (1-5)

REAL*4 PKQTY_F ! PLACEHOLDER FOR PF QTY REAL*4 OPQTY_F ! PLACEHOLDER FOR OF QTY REAL*4 PKQTY_I ! PLACEHOLDER FOR PI QTY REAL*4 OPQTY_I ! PLACEHOLDER FOR OI QTY REAL*4 ADJ ! VOLUME TO ADJUST NEW ENGLAND IMPORTS IF NET DEMAND FALLS TOO LOW REAL*4 MINDMD ! MINIMUM NET NODE DEMAND IN NEW ENGLAND

INTEGER*4 V, W, C LOGICAL TMPSET/.TRUE./ ! -------------

IF (TMPSET) THEN IF (MODYR .GT. LHISYR) THEN TMPSET = .FALSE. ENDIF

PERMTH(PKNET) = 1./4. PERMTH(OPNET) = 1./8. DO C=1,NETWORK DO W=1,TNODES SPERMTH(C,W) = 0.30 IF (C.EQ.1) THEN SPERMTH(C,W) = HSPERJAN(W,LHISYR+1) ENDIF ENDDO DO W=1,SNODES IF(SUPARRAY(W).EQ.1) THEN PPERMTH(C,W) = PERMTH(C) IF (C.EQ.1 .AND. SUPTYPE(W).LE.2) THEN PPERMTH(C,W) = HPPERJAN(W,LHISYR+1) ENDIF IF(W.GE.FSRGN(1).AND.W.LT.FSRGN(3)) PPERMTH(C,W+FSRGN(7)-1)=PPERMTH(C,W) !AD GAS ENDIF

ENDDO DO W=1,NNGEM-1 UCPERMTH(C,W) = PERMTH(C) IF (C.EQ.1) THEN UCPERMTH(C,W) = HUCPERJAN(W,LHISYR+1) ENDIF !xxx UCPERMTH(C,W) = .30

ENDDO DO W=1,DNODES!xxx NCPERMTH(C,W,1) = .40

NCPERMTH(C,W,1) = .30 NCPERMTH(C,W,2) = .28 NCPERMTH(C,W,3) = .26 NCPERMTH(C,W,4) = PERMTH(C) !xxx NCPERMTH(C,W,1) = PERMTH(C) !xxx NCPERMTH(C,W,2) = PERMTH(C) !xxx NCPERMTH(C,W,3) = PERMTH(C) !xxx NCPERMTH(C,W,4) = PERMTH(C)

IF (C.EQ.1) THEN DO V=1,DSEC-1 NCPERMTH(C,W,V) = HCPERJAN(W,V,LHISYR+1) ENDDO ENDIF ENDDO ENDDO ENDIF

! RESET NODE DEMANDS: CONST DMDS/SUP

DO NET=1,NETWORK DO N=1,TNODES+SNODES+STNODES NODE_DMD(NET,N) = 0.0 ENDDO

DO N=1,TNODES ! write(69,*) cycle,'cdmd',modyr,n,net,NODE_CDMD(NET,N)

NODE_DMD(NET,N) = NODE_CDMD(NET,N) ! peak month MTH_CONS(NET,N) = MTH_CDMD(NET,N) ENDDO ENDDO

IF (((CYCLE .EQ. 1) .OR. (CYCLE.EQ.0)) .AND. & (CURITR .EQ. 1)) THEN ! WRITE (NGODTM,*) " YR IT CY RG PEAK OFFPEAK", ! * " <--NODE_CDMD" ! DO N=1,TNODES ! WRITE (NGODTM,110) MODYR,CURITR,CYCLE,N, ! * (NODE_CDMD(NET,N),NET=1,NETWORK) ! ENDDO

WRITE (NGODTM,*) " YR IT CY RG RES COM", & " IND TRN <--ZNGQTY_F" DO N=1,DNODES WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, & (ZNGQTY_F(SEC,N),SEC=1,DSEC-1) ENDDO WRITE (NGODTM,*) " YR IT CY RG RES COM", & " IND TRN <--ZNGQTY_I" DO N=1,DNODES WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, & (ZNGQTY_I(SEC,N),SEC=1,DSEC-1) ENDDO WRITE (NGODTM,*) " YR IT CY RG U_FIRM U_INTR", & " <--ZNGUQTY_*" DO J=1,NNGEM-1 WRITE (NGODTM,111) MODYR,CURITR,CYCLE,J, & ZNGUQTY_F(J),ZNGUQTY_I(J) ENDDO ENDIF 110 FORMAT(1X,I4,I3,I3,I3,2(F10.3)) 111 FORMAT(1X,I4,I3,I3,I3,4(F10.3))

! RESET NODE DEMANDS: NEW END-USE DMDS! NON-UTILITY

DO N=1,DNODES DO SEC=1,DSEC-1 PKQTY_F = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N) OPQTY_F = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_F(SEC,N) PKQTY_I = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N) OPQTY_I = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_I(SEC,N) NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + & PKQTY_F + PKQTY_I NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + & OPQTY_F + OPQTY_I NGQTY_SF(PKNET,SEC,N) = PKQTY_F NGQTY_SF(OPNET,SEC,N) = OPQTY_F NGQTY_SI(PKNET,SEC,N) = PKQTY_I NGQTY_SI(OPNET,SEC,N) = OPQTY_I ! peak month MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + & ((PKQTY_F + PKQTY_I) * NCPERMTH(PKNET,N,SEC)) MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + & ((OPQTY_F + OPQTY_I) * NCPERMTH(OPNET,N,SEC)) ENDDO ENDDO

! UTILITY DO J=1,NNGEM-1 N = EMMSUB_NG(J) PKQTY_F = PKSHR_UDMD_F(J) * ZNGUQTY_F(J) OPQTY_F = (1.-PKSHR_UDMD_F(J)) * ZNGUQTY_F(J) PKQTY_I = PKSHR_UDMD_I(J) * ZNGUQTY_I(J) OPQTY_I = (1.-PKSHR_UDMD_I(J)) * ZNGUQTY_I(J) NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + & PKQTY_F + PKQTY_I NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + & OPQTY_F + OPQTY_I NGUQTY_SF(PKNET,J) = PKQTY_F NGUQTY_SF(OPNET,J) = OPQTY_F NGUQTY_SI(PKNET,J) = PKQTY_I NGUQTY_SI(OPNET,J) = OPQTY_I ! peak month MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + & ((PKQTY_F + PKQTY_I) * UCPERMTH(PKNET,J)) MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + & ((OPQTY_F + OPQTY_I) * UCPERMTH(OPNET,J)) ENDDO

! RESET NODE DEMANDS: NEW END-USE DMDS

! DO N=1,DNODES ! DO SEC=1,DSEC-1 ! NGQTY_SF(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N) ! NGQTY_SF(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) * ! * ZNGQTY_F(SEC,N) ! NGQTY_SI(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N) ! NGQTY_SI(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) * ! * ZNGQTY_I(SEC,N) ! NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + ! * NGQTY_SF(PKNET,SEC,N) + NGQTY_SI(PKNET,SEC,N) ! NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + ! * NGQTY_SF(OPNET,SEC,N) + NGQTY_SI(OPNET,SEC,N) ! ENDDO ! ENDDO

! NOTE: THE FOLLOWING IS DONE BECAUSE NGUQTY_SF AND _SI ARE NEEDED ! IN SUBROUTINE NGSET_SECPR TO DETERMINE END-USE UTILITY PR

! DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16! NGUQTY_SF(PKNET,J) = PKSHR_UDMD_F(J) * NGUQTY_F(J) ! NGUQTY_SF(OPNET,J) = (1.-PKSHR_UDMD_F(J)) * ! * NGUQTY_F(J) ! NGUQTY_SI(PKNET,J) = PKSHR_UDMD_I(J) * NGUQTY_I(J) ! NGUQTY_SI(OPNET,J) = (1.-PKSHR_UDMD_I(J)) * ! * NGUQTY_I(J) ! ENDDO

IF (CYCLE.EQ.1 .AND. FIXLNGFLG) THEN !YD1LNG: DO ADJ ONLY WHEN FIXED LNG

I = 1 ! FOR NEW ENGLAND, CHECK IF NODE_DMD TOO LOW N = MAPLNG_NG(I) ADJ = 0.0 MINDMD = 50.0 IF (NODE_DMD(PKNET,N).LT.MINDMD) ADJ = ADJ + (MINDMD - NODE_DMD(PKNET,N)) / PKSHR_ILNG(I)

IF (NODE_DMD(OPNET,N).LT.MINDMD) ADJ = ADJ + (MINDMD - NODE_DMD(OPNET,N)) / (1.-PKSHR_ILNG(I))

IF (ADJ.GT.oOGQNGIMP(14+I,CURIYR)) ADJ = oOGQNGIMP(14+I,CURIYR) NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + (ADJ * PKSHR_ILNG(I)) NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + (ADJ * (1.-PKSHR_ILNG(I))) oOGQNGIMP(14+I,CURIYR) = oOGQNGIMP(14+I,CURIYR) - ADJ

FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) - PKSHR_ILNG(I) * ADJ FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) - (1.-PKSHR_ILNG(I)) * ADJ

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (PKSHR_ILNG(I) * ADJ * 0.25) !1/4 MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + ((1.-PKSHR_ILNG(I))*ADJ* 0.125) !1/8

ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! MOVE DOWN TREE, ! DETERMINE SUPPLY SHARES AND FLOWS, ! ACCUMULATE DEMANDS AT SOURCE NODES ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! CALLS TO: NGSHR_CALC ! NGSHR_MAXCHK ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGDOWN_TREE(NET) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngsteoinc' include 'nghistinc' include 'ngcdmdinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 L,N,A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 PFUEL_FLG(ARCS) ! FLAG INDICATING PIPE FUEL CONSUMPREAL*4 TFLOW ! TOTAL FLOW ALONG PIPE ARCS INTO A NODE

REAL*4 NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC REAL*4 GAMMATMP ! TMP PLACEHOLDER FOR GAMMAFAC FOR OPT 5

LOGICAL ONCE/.TRUE./ ! DO ONLY ONCE ! -------------

IF (ONCE) THEN ONCE = .FALSE. GAMMATMP = GAMMAFAC ! temp ENDIF

! INITIALIZE BKSTOP TO ZERO BEFORE ALLOCATING SHARES

DO N=1,TNODES BKSTOP(NET,N) = 0.0 ENDDO !CCC BKSTOP_FLG = 0

! LOOP OVER PROCESSING NODES GOING DOWN NETWORK

DO L=1,NPROC ! NUMBER OF PROCESSING NODES DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

! DEFINE PIPE FUEL CONSUMPTION AND ADD TO NET DMD (NODE_DMD) ! PFUEL_FAC = PF / NODE_DMD(W/O PF)

IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN IF ((NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)).NE.0.0) & HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / & (NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)) ELSE IF (NODE_DMD(NET,DEST) .LE. 0.0) THEN IF (DEST.LE.DNODES) DISCR(NET,DEST,MODYR) = DISCR(NET,DEST,MODYR) - NODE_DMD(NET,DEST) + 1. !YD1? NODE_DMD(NET,DEST) = 1. !YD1: THIS CONDITION CHANGES ZERO DMD AT LNG NODES MAKING BKSTOP>0

ENDIF PFUEL(NET,DEST) = PFUEL_FAC(NET,DEST) * SCALE_PF(MODYR) * &

(NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)) * FE_PFUEL_FAC(MODYR) PFUEL(NET,DEST) = AMIN1(PFUEL(NET,DEST),0.15*NODE_DMD(NET,DEST) ) ENDIF

NODE_DMD(NET,DEST) = NODE_DMD(NET,DEST) + PFUEL(NET,DEST)

! TEMPCODE: 09/03/97

INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST) ! TEMPCODE: 09/03/97

! CALCULATE SUPPLY SHARES AND CHECK AGAINST MAX SHARES (FLOWS)

IF (SHR_OPT .EQ. 1) THEN ! original method CALL NGSHR_CALC(DEST,NET) ELSE IF (SHR_OPT .EQ. 2) THEN ! func (added net dmd) if (modyr .le. lhisyr) then ! temp GAMMAFAC = 1.0 ! temp CALL NGSHR_CALC(DEST,NET) ! temp else ! temp GAMMAFAC = GAMMATMP ! temp CALL Z2NGSHR_CALC(DEST,NET) endif ! temp ELSE IF (SHR_OPT .EQ. 3) THEN ! func (added net dmd): not good if (modyr .le. lhisyr) then ! tempCALL NGSHR_CALC(DEST,NET) ! temp

else ! temp CALL Z3NGSHR_CALC(DEST,NET) endif ! temp ELSE IF (SHR_OPT .EQ. 4) THEN ! func (added rem cap) if (modyr .le. lhisyr) then ! temp CALL NGSHR_CALC(DEST,NET) ! temp else ! temp CALL Z4NGSHR_CALC(DEST,NET) endif ! temp ELSE IF (SHR_OPT .EQ. 5) THEN ! func (added rem cap) if (modyr .le. lhisyr) then ! temp GAMMAFAC = 1.0 ! temp CALL NGSHR_CALC(DEST,NET) ! temp else ! temp GAMMAFAC = GAMMATMP ! temp CALL Z5NGSHR_CALC(DEST,NET) endif ! temp ELSE IF (SHR_OPT .EQ. 6) THEN ! func (added net dmd) if (modyr .le. lhisyr) then ! temp CALL NGSHR_CALC(DEST,NET) ! temp else ! temp CALL Z6NGSHR_CALC(DEST,NET) endif ! temp ENDIF

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN CALL NGSHR_LHISYR(DEST,NET) ELSE IF ((NET .EQ. PKNET) .AND. (MODYR.GT.NOBLDYR)) THEN !utz MTH_CONS(NET,DEST) = MTH_CONS(NET,DEST) + & !utz (PERMTH(NET) * PFUEL(NET,DEST)) !utz CALL NGSHR_MAXCHK(DEST,NET) !utz CALL NGSHR_MTHCHK(DEST,NET) !utz ELSE !utz CALL NGSHR_MAXCHK(DEST,NET) ENDIF !utz ENDIF

! SET ARC FLOWS AND ADD TO TOTAL DEMANDS AT SOURCE NODES. ! ALSO, ADD STORAGE SUPPLY IN PK TO NODE DMD IN OP. ! NOTE: NODE_DMD(1,STORAGE) ONLY USED TO TRACK STORAGE QTY.

TFLOW = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) FLOW(NET,A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST) NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A) IF ((NET.EQ.PKNET) .AND. (SRC.GT.(TNODES+SNODES))) THEN NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + FLOW(NET,A) ENDIF ! SET REMIANING FLOW

IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)-.0001) THEN FLOW_REM(NET,A) = 0.0 ! REMAINING FLOW = 0 ELSE FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A) ENDIF

IF (SRC .LE. TNODES) THEN PFUEL_FLG(A) = 1 ! PIPEFUEL CONS ON THIS ARC TFLOW = TFLOW + FLOW(NET,A) ELSE PFUEL_FLG(A) = 0 ENDIF ENDDO! SET PIPEFUEL ALONG PIPE ARC ONLY

DO A=ARC_1,ARC_2 IF (PFUEL_FLG(A) .EQ. 1 .AND. TFLOW.GT.0.000001) THEN ARC_PFUEL(NET,A)= (PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST))* & (FLOW(NET,A)/TFLOW) ELSE ARC_PFUEL(NET,A) = 0.0 ENDIF ENDDO ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS ! ! STATUS: UNDER CONSTRUCTION ! ! CALLED BY: NGDOWN_TREE ! ! FUNCTIONS USED: ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSHR_LHISYR(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'nghistinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A,I ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE) INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD) INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR INTEGER*4 CNBRD ! AID IM MAPPING FR ARC TO BORDER XING

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR REAL*4 SUMMAX ! TOTAL SHARES AT MAX SHR REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

REAL*4 TMPFLO ! HOLDS PIPE FLOW TEMPORARILY REAL*4 SUMFAC ! FACTOR (1,0) TO SET SHR=0 IF NEEDED

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

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

! SET HISTORICAL SUPPLY SHR AND MAX SHR

TMAXFLO = 0.0 CHK = 0 ! NETDMD = NODE_DMD(NET,DEST) DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCSSRC = ARC_2NODE(A,1)

MAXFLG(A) = 0 OLDFLG(A) = 0 !!!! IF ((SRC .GT. TNODES) .AND. (SRC .LE. TNODES+SNODES)) THEN ! SUPPLY !!!x IF (SRC .GT. TNODES) THEN ! SUPPLY & STORAGE !!!z IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2)) THEN ! SUPPLY&STR

IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2) .AND. & !YD1: CHANGE IF OTHER SUPPLY BECOMES VARIABLE!!!!

(SRC.NE.TNODES+SNODES-lSNODES-3)) THEN ! SUP, STR, NOT CAN SUP MAXFLO(NET,A) = FLOW(NET,A) IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST) ELSE SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK? ENDIF SHR(NET,A,MODYR) = SHRMAX(A) TMAXFLO = TMAXFLO + MAXFLO(NET,A) ! NETDMD = NETDMD - FLOW(NET,A) ! OLDFLG(A) = 1

ELSEIF (SRC.GT.DNODES .AND. SRC.LE.TNODES-LNGNODES-2 .AND. ARC_1.NE.ARC_2) THEN CNBRD = 0 DO I=1,NXMAPUS IF (CAN_XMAPUS(I,2).EQ.SRC .AND. CAN_XMAPUS(I,1).EQ.DEST) CNBRD = I ENDDO IF (CNBRD.EQ.0) WRITE(6,*) ' NGCHECK MAP NGSHR_LHISYR ',SRC,DEST IF (NET.EQ.PKNET) THEN MAXFLO(NET,A) = HAFLOW(A,LHISYR) * HPKSHR_ICAN(LHISYR) ELSE MAXFLO(NET,A) = HAFLOW(A,LHISYR) * (1.-HPKSHR_ICAN(LHISYR)) ENDIF IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST) ELSE SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK? ENDIF SHR(NET,A,MODYR) = SHRMAX(A) TMAXFLO = TMAXFLO + MAXFLO(NET,A) ELSE ! PIPELINE ARCS !YD1LNG: PROCESS LNG NODES DIFFERENTLY

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION IF (ARC_1 .NE. ARC_2) THEN TMPFLO = AMIN1((MAXFLO(NET,A)*.99999), &

(SHR(NET,A,MODYR)*NODE_DMD(NET,DEST))) IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHR(NET,A,MODYR) = TMPFLO / NODE_DMD(NET,DEST) ELSE SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) ! temp, 10-26-05 ?????? OK? ENDIF ENDIF IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST) ELSE SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK? ENDIF TMAXFLO = TMAXFLO + MAXFLO(NET,A) ! OLDFLG(A) = 0

ENDIF ENDDO

! check this

IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN ! DMD < TMAXFLO CHNG = 1 DO WHILE (CHNG .EQ. 1) CHK = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCSIF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW MAXFLG(A) = 1 IF (MAXFLG(A) .NE. OLDFLG(A)) THEN CHK = 1 OLDFLG(A) = MAXFLG(A) ENDIF ENDIF ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS SUMMAX = 0.0 SUMREM = 0.0 SUMSHR = 0.0

CNT0 = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN CNT0 = CNT0 + 1 SUMSHR = SUMSHR + SHR(NET,A,MODYR) ELSE SUMMAX = SUMMAX + SHR(NET,A,MODYR) ENDIF ENDDO IF ((SUMMAX .GT. 1.0) .AND. (SUMSHR.GE. 0.0)) THEN SUMREM = 0.0 SUMFAC = 0.0 ELSE IF ((SUMSHR+SUMMAX) .GT. 1.0) THEN SUMREM = 0.0 SUMFAC = (1.-SUMMAX) / SUMSHR ELSE SUMREM = 1. - (SUMSHR+SUMMAX) SUMFAC = 1.0 ENDIF ENDIF ! DISTRIBUTE OVER UNCONSTR ARCS DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN IF (SUMSHR .GT. 0.0) THEN SHR(NET,A,MODYR) = (SUMFAC + (SUMREM/SUMSHR)) * & SHR(NET,A,MODYR) ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0) ENDIF ENDIF ENDDO ELSE CHNG = 0 ENDIF ENDDO

ELSE ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO !CCC BKSTOP_FLG = 1

DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = SHRMAX(A) ENDDO

WRITE(NGOERR,100) & ! ATTN MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), & TMAXFLO, RBKSTOP_PADJ(NET,DEST) ENDIF100 FORMAT(1X,'ATTN4--BKSTOP: YR,CYC,NET,NODE= ',I4,I3,I2,I3, &

' BKSTOP,DMD,MAX,PADJ= ', 3F10.4,F7.3)

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET REMAINING FLOW ALONG ARC ! ! STATUS: COMPLETE ! ! CALLED BY: NGDOWN_TREE ! HNGDOWN_TREE ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION NGSET_FLOWREM(NET,A) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A ! COUNTERS INTEGER*4 SRC ! SOURCE NODE ALONG ARC

REAL*4 FAC ! PK/OP FACTOR ! ----------

SRC = ARC_2NODE(A,1) IF (NET .EQ. PKNET) THEN ! REMAINING FLOW IN PK BASED ON CUR CAP IF (SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARC FAC = PKUTZ(A) ELSE ! PIPELINE OR SUPPLY ARC FAC = PKSHR_YR * PKUTZ(A) ENDIF NGSET_FLOWREM = AMAX1( 0., FAC*CURPCAP(A,MODYR) - FLOW(NET,A)) ELSE ! REMAINING FLOW IN OP BASED ON MAX OP CAP NGSET_FLOWREM = AMAX1( 0., MAXFLO(NET,A) - FLOW(NET,A)) ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET SECONDARY FLOWS OUT OF MIDDLE ATLANTIC ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGSECFLOW2 IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'ngsteoinc' include 'nghistinc'include 'ogglobal'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DST(3) ! THREE NODES WITH SEC FLOWS OUT OF SRC(3) INTEGER*4 SRC(4) ! THREE NODES WITH SEC FLOWS INTO DST(3) INTEGER*4 DEST ! SPECIFIC DESTINATION NODE INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 I,J ! COUNTERS INTEGER*4 ICNT ! KEEP TRACK OF NUMBER OF ARCS GOING INTO DST INTEGER*4 ARCPRM ! ARC NUMBER FOR PRIMARY ARC INTO DST INTEGER*4 ARCPRM2 ! ARC NUMBER FOR PRIMARY ARC ALONG SEC ARC INTO DST INTEGER*4 ARCSEC ! ARC NUMBER FOR SECONDARY ARC OUT OF DST INTEGER*4 ARCSEC2 ! ARC NUMBER FOR SECOND SECONDARY ARC OUT OF DST

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 SHRLAG(10) ! LAST YEAR'S SHARES BASED ON FLWLAG REAL*4 SHRTST(10) ! THIS YEAR'S SHARES IF KEY SEC FLOW INCLUDED REAL*4 REV_ARC_SHRPR ! SHARE PRICE ALONG REVERSE FLOW ARC REAL*4 REV_ARC_SHRPR2 ! SHARE PRICE ALONG SECOND REVERSE FLOW INTO CANADA REAL*4 FLWTOT ! TOTAL FLOW LAST ITERATION INTO NEW DEST ARC, INCL FROM 2 REAL*4 SHRSUM ! SUM OF NONNORMALIZED SHARES INTO NEW DEST ARC, INCLU FROM 2 REAL*4 REV_FLOW(NETWORK,4) ! FINAL FLOW BY NETWORK ON REVERSE FLOW ARC INTO DEST J REAL*4 FLWLAG(10,NETWORK,3) ! FLOW INTO DEST LAST YEAR, INCL KEY SEC FLOW, 10 MAX NUMBER REAL*4 FLWLAGTOT(NETWORK,3) ! TOTAL FLOW LAST YEAR INTO NEW DEST ARC, INCL FROM 2 REAL*4 FLW(4) ! HOLDING ARRAY REAL*4 MINFLW(4) ! HOLD PRESET MINIMUM FLOW LEVELS real*4 price(10)

DATA DST/3,5,23/ DATA SRC/2,2,14,15/ ! -------------

DO NET = 1,NETWORK DO J=1,3 SHRTST = 0.0 SHRLAG = 0.0 IF (CURITR.EQ.1) THEN DO I=1,10 FLWLAG(I,NET,J) = 0.0 ENDDO ENDIF PRICE = 0.0 DEST = DST(J) ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) N = ARC_2 - ARC_1 + 1 ARCPRM = NODE_2ARC(DEST,SRC(J)) ARCSEC = SNODE_2ARC(SRC(J),DEST)

IF (J.EQ.3) THEN ARCPRM2 = NODE_2ARC(DEST,SRC(J+1)) ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST) ENDIF

!!!!! REV_ARC_SHRPR = NODE_SHRPR(NET,SRC(J)) + ARC_SHRFEE(NET,ARCPRM)

REV_ARC_SHRPR = NODE_SHRPR(NET,SRC(J))

IF (CURITR.EQ.1) THEN FLWLAG(N+1,NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET) FLWLAGTOT(NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET) !INITIALIZE IF (NET.EQ.PKNET) MINFLW(J) = SAFLOW(ARCSEC,MODYR-1) ! ch to "-1" for conv prob, but now not used

ELSE FLWTOT = SAFLOW(ARCSEC,MODYR) * SHRYR(NET) ! INITIALIZE ENDIF INVPR_SUM = (1. / REV_ARC_SHRPR) ** GAMMAFAC ! INITIALIZE price(n+1) = rev_arc_shrpr

IF (J.EQ.3) THEN

! don't have tariff for 3->23, so make assumption !!!!!! REV_ARC_SHRPR2 = NODE_SHRPR(NET,3) + 0.50

REV_ARC_SHRPR2 = NODE_SHRPR(NET,3)

IF (CURITR.EQ.1) THEN FLWLAG(N+2,NET,J) = SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET) FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET) ! INITIALIZE IF (NET.EQ.PKNET) MINFLW(J+1) = SAFLOW(ARCSEC2,MODYR-1) ! ch to "-1" for conv prob, but now not used

ELSE FLWTOT = FLWTOT + SAFLOW(ARCSEC2,MODYR) * SHRYR(NET) ! INITIALIZE ENDIF INVPR_SUM = INVPR_SUM + (1. / REV_ARC_SHRPR2) ** GAMMAFAC ! INITIALIZE price(n+2) = rev_arc_shrpr2 ENDIF

ICNT = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ICNT = ICNT + 1 IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC) price(icnt) = arc_shrpr(net,a) IF (CURITR.EQ.1) THEN FLWLAG(ICNT,NET,J) = FLOW(NET,A) FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + FLOW(NET,A) ELSE FLWTOT = FLWTOT + FLOW(NET,A) ENDIF ELSE WRITE(4,*) ' NGERR NEG ARC_SHRPR ', NET,DEST ENDIF ENDDO DO I=1,N+1 SHRLAG(I) = FLWLAG(I,NET,J) / FLWLAGTOT(NET,J) ENDDO IF (J.EQ.3) THEN SHRLAG(N+2) = FLWLAG(N+2,NET,J) / FLWLAGTOT(NET,J) SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+2) * & (((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM) SHRTST(N+2)= SHRLAG(N+2) * FLOAT(N+2) * & (((1./REV_ARC_SHRPR2)**GAMMAFAC) / INVPR_SUM) SHRSUM = SHRTST(N+1) + SHRTST(N+2) ! INITIALIZE ELSE SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+1) * & (((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM) SHRSUM = SHRTST(N+1) ! INITIALIZE ENDIF

ICNT=0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE ICNT = ICNT + 1 IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0)) THEN IF (J.EQ.3) THEN SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+2) * &(((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM) ELSE SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+1) * & (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM) ENDIF SHRSUM = SHRSUM + SHRTST(ICNT) ELSE WRITE(4,*) ' NGERR NEG INVPR_SUM ', NET,DEST ENDIF ENDDO

IF (CURITR.EQ.1) FLWTOT = FLWLAGTOT(NET,J) IF (SHRSUM .GT. 0.0) THEN REV_FLOW(NET,J) = FLWTOT * SHRTST(N+1) / SHRSUM IF (J.EQ.3) REV_FLOW(NET,J+1) = FLWTOT * SHRTST(N+2) / SHRSUM ELSE REV_FLOW(NET,J) = 0.0 IF (J.EQ.3) REV_FLOW(NET,J+1) = 0.0 ENDIF ! if (fcrl.eq.1) then ! write(4,1234) modyr,curitr,net,j,(price(i),i=1,n+2) !1234 format(1x,' JBE2 yr,itr,net,j ',4i5,10f6.2) ! write(4,1236) modyr,curitr,net,j,(shrtst(i),i=1,n+2),shrsum !1236 format(1x, ' JBE4 yr,itr,net,j ',4i5,11f6.3) ! endif

ENDDO ENDDO DO J=1,3 DEST = DST(J) ARCSEC = SNODE_2ARC(SRC(J),DEST) ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST) FLW(J) = REV_FLOW(PKNET,J) + REV_FLOW(OPNET,J) IF (J.EQ.3) FLW(J+1) = REV_FLOW(PKNET,J+1) + REV_FLOW(OPNET,J+1)

!!!!! SAFLOW(ARCSEC,MODYR) = AMAX1(FLW(J),MINFLW(J)) ! not using minflw to deal with conv prob !!!!! IF (J.EQ.3) SAFLOW(ARCSEC2,MODYR) = AMAX1(FLW(J+1),MINFLW(J+1))

SAFLOW(ARCSEC,MODYR) = FLW(J) IF (J.EQ.3) SAFLOW(ARCSEC2,MODYR) = FLW(J+1) ENDDO

ARC_1 = SNODE_2ARC(2,14) ARC_2 = SNODE_2ARC(14,23) IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) THEN SAFLOW(ARC_2,MODYR) = CANEXP(2,MODYR) + CNFLOW_OUT(2,MODYR) ENDIF SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR) SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR)) SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR)) CANEXP(2,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(2,MODYR) oOGQNGEXP(2,CURIYR) = CANEXP(2,MODYR) ARC_1 = SNODE_2ARC(3,15) ARC_2 = SNODE_2ARC(15,23) IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) THEN SAFLOW(ARC_2,MODYR) = CANEXP(3,MODYR) + CNFLOW_OUT(3,MODYR) ENDIF SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR) SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR)) SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR)) CANEXP(3,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(3,MODYR) oOGQNGEXP(3,CURIYR) = CANEXP(3,MODYR)
! if (fcrl.eq.1) then ! IF (MODYR.EQ.LHISYR+1) WRITE(4,*) 'FLOW2 2->3 2->5 2->23 3->23'! WRITE(4,4344) MODYR,(FLW(J),J=1,4) !4344 FORMAT (1X, 'FLOW2 ',I5,4F8.3) ! endif

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES ! ! STATUS: COMPLETE ! ! CALLED BY: NGDOWN_TREE ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 SHRSUM ! SUM OF NEW SHR'S--USED FOR NORMALIZING ! -------------

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) INVPR_SUM = 0.0 N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC) ENDIF ENDDO

SHRSUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0)) THEN SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * & (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM) SHRSUM = SHRSUM + SHR(NET,A,MODYR) ELSE SHR(NET,A,MODYR) = 0.0 ENDIF ENDDO IF (SHRSUM .GT. 0.0) THEN DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM ENDDO ENDIF ENDIFRETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! << OPTION 2 >> ! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE ! ! 8/30/99 ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE Z2NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP INTEGER*4 LASTCYC ! TRACKS WHEN NEW CYCLE BEGINS

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1 REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO ! -------------

!CCC IF (CYCLE .LE. 2) THEN !CCC MIN_PCTFLO = PCTFLO ! PCT OF T-1 FLOW RETAINED IN T !CCC LASTCYC = CYCLE !CCC ELSE !CCC IF (CYCLE .NE. LASTCYC) THEN !CCC MIN_PCTFLO = MIN_PCTFLO + ((1.-MIN_PCTFLO) / 10.) !CCC LASTCYC = CYCLE !CCC ENDIF !CCC ENDIF

MIN_PCTFLO = PCTFLO ! PCT OF T-1 FLOW RETAINED IN T

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) PR_SUM = 0.0 N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST)) IF (TADDDMD .LE. 0.0) THEN MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) ) TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))IF (CYCLE .EQ. 1) THEN

WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &

"FOR DEST, YEAR = ", DEST,MODYR ENDIF ENDIF IF (TADDDMD .GE. 0.0) THEN

! NET DMD INCREASES ! DEFINE SHR TO INCREASE FLOW AS [INVP/(SUM INVP)] DO A=ARC_1,ARC_2 IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN PR_SUM = PR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC) ENDIF ENDDO

SUMSHR = 0.0 DO A=ARC_1,ARC_2 IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (PR_SUM .GT. 0.0)) THEN ADDSHR(A) = (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / &

PR_SUM) ELSE ADDSHR(A) = 0.0 ENDIF SUMSHR = SUMSHR + ADDSHR(A) ENDDO IF (SUMSHR .GT. 0.0) THEN DO A=ARC_1,ARC_2 ADDSHR(A) = ADDSHR(A) / SUMSHR ADDDMD(A) = ADDSHR(A) * TADDDMD NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A) ENDDO ELSE DO A=ARC_1,ARC_2 NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO ! ???? wrong ENDDO ENDIF

! NET DMD DECREASES, SO MAKE SURE FLOWS AREN'T < 0

! DEFINE SHR TO DECREASE FLOW AS P/(SUM P) ELSE

WRITE(NGOERR,*) " ERROR Z2NG: NEED TO CHECK CALC OF ", & "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, & CURITR, CYCLE

ENDIF ! end check for added net dmd > 0

DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST) ENDDO

! CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)
ENDIF ! end check for single arc into node

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! << OPTION 3 >> ! NEW SHARING ALGORITHM BASED ON ARC PRICES (OPT 1) ! AND USING REMAINING FLOW (COMBINED OPT 2 & 4) for gammafac ! ! 8/30/99! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE Z3NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1 REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 PRV_REMCAP(ARCS) REAL*4 SUM_REMCAP REAL*4 ARC_GAMMAFAC(ARCS) REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO ! -------------

MIN_PCTFLO = PCTFLO ! PCT OF T-1 FLOW RETAINED IN T ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) PR_SUM = 0.0 N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE

! opt 4 ! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A) IF (NET .EQ. PKNET) THEN IF (SRC .GT. TNODES+SNODES) THEN ! storage CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) ELSE IF(SRC .LE. TNODES) THEN ! pipe CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR ELSE ! supply CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ELSE CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ENDDOSUM_REMCAP = 0.0

DO A=ARC_1,ARC_2 IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** & ALPHAFAC ELSE PRV_REMCAP(A) = 0.0 ENDIF SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A) ENDDO

INVPR_SUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A) IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (CUR_EFFCAP(NET,A).GT. 0.0)) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A)) ENDIF ENDDO

SUMSHR = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0) .AND. & (CUR_EFFCAP(NET,A).GT. 0.0)) THEN ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) * & (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM) ELSE ADDSHR(A) = 0.0 ENDIF SUMSHR = SUMSHR + ADDSHR(A) ENDDO ! opt 4 IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE SHR(NET,A,MODYR) = ADDSHR(A) / SUMSHR ENDDO ELSE DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) ENDDO ENDIF
ENDIF ! end check for single arc into node

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! USE SHARING ALGORITHM option 4 TO CALCULATE SHARES ALONG ARCS INTO NODES ! ! STATUS: COMPLETE ! ! CALLED BY: NGDOWN_TREE ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE Z4NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ON ARC INTO DEST NODE INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 SHRSUM ! SUM OF NEW SHR'S--USED FOR NORMALIZING REAL*4 PRV_REMCAP(ARCS) REAL*4 SUM_REMCAP REAL*4 ARC_GAMMAFAC(ARCS) REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC ! -------------

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE ! set & sum rem cap for t-1 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A) IF (NET .EQ. PKNET) THEN IF (SRC .GT. TNODES+SNODES) THEN ! storage CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) ELSE IF(SRC .LE. TNODES) THEN ! pipe CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR ELSE ! supply CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ELSE CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ENDDO

SUM_REMCAP = 0.0 DO A=ARC_1,ARC_2 IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** & ALPHAFAC ELSE PRV_REMCAP(A) = 0.0 ENDIF SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A) ENDDO

INVPR_SUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ARC_GAMMAFAC(A) = 1.0 - (PRV_REMCAP(A) / SUM_REMCAP) IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A)) ENDIF ENDDO

SHRSUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0)) THEN SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * &(((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

SHRSUM = SHRSUM + SHR(NET,A,MODYR) ELSE SHR(NET,A,MODYR) = 0.0 ENDIF ENDDO IF (SHRSUM .GT. 0.0) THEN DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM ENDDO ENDIF ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! << OPTION 5 >> ! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE ! AND USING REMAINING FLOW FRACTION TIMES PRICE RATIOS ! ! 12/02/99 ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE Z5NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1 REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1) REAL*4 ADJFAC_REMCAP ! ADJ FACTOR FR REM CAP IN OP REAL*4 SUM_REMCAP ! TOTAL REMAINING CAPACITY REAL*4 ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO ! -------------

MIN_PCTFLO = PCTFLO ! PCT OF T-1 FLOW RETAINED IN T ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)PR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE ! opt 2 TADDDMD = NODE_DMD(NET,DEST) - & (MIN_PCTFLO * PRVNODE_DMD(NET,DEST)) IF (TADDDMD .LE. 0.0) THEN MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) ) TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST)) IF (CYCLE .EQ. 1) THEN WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &

"FOR DEST, YEAR = ", DEST,MODYR ENDIF ENDIF
IF (TADDDMD .GE. 0.0) THEN ! note: this is true from above calc

! NET DMD INCREASES ! opt 4 ! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A) IF (NET .EQ. PKNET) THEN IF (SRC .GT. TNODES+SNODES) THEN ! storage CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) ELSE IF(SRC .LE. TNODES) THEN ! pipe CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR ELSE ! supply CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ELSE CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ENDDO

SUM_REMCAP = 0.0 DO A=ARC_1,ARC_2 IF (CUR_EFFCAP(NET,A) .GT. (MIN_PCTFLO*PRVFLOW(NET,A))) THEN PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - & (MIN_PCTFLO*PRVFLOW(NET,A))) ** ALPHAFAC ELSE PRV_REMCAP(A) = 0.0 ENDIF SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A) ENDDO

INVPR_SUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ARC_GAMMAFAC(A) = GAMMAFAC ! tmp: hardcoded IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A)) ENDIF ENDDO

SUMSHR = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0)) THEN IF (NET .EQ. PKNET) THEN ADJFAC_REMCAP = 1.0ELSE ! add adj factor fr rem cap in OP ADJFAC_REMCAP = float(N) * PRV_REMCAP(A) / SUM_REMCAP ENDIF ADDSHR(A) = ADJFAC_REMCAP * & (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM) ELSE ADDSHR(A) = 0.0 ENDIF SUMSHR = SUMSHR + ADDSHR(A) ENDDO

IF (SUMSHR .GT. 0.0) THEN DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE ADDSHR(A) = ADDSHR(A) / SUMSHR ADDDMD(A) = ADDSHR(A) * TADDDMD NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A) ENDDO ELSE DO A=ARC_1,ARC_2 NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO WRITE(NGOERR,*) " NEWFLOW: ",MODYR," ",A," ",NEWFLOW(A), & " ",NODE_DMD(NET,DEST) ENDDO ENDIF ELSE

WRITE(NGOERR,*) " ERROR Z5NG: NEED TO CHECK CALC OF ", & "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, & CURITR, CYCLE

ENDIF

DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST) ENDDO

! CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)
ENDIF ! end check for single arc into node

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! << OPTION 6 >> ! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE ! AND USING REMAINING FLOW (COMBINED OPT 2 & 4) ! ! 8/30/99 ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE Z6NGSHR_CALC(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A,N ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE INTEGER*4 NET ! REPRESENTS PK,OP NETWORKINTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW

INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1 REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS REAL*4 PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1) REAL*4 SUM_REMCAP ! TOTAL REMAINING CAPACITY REAL*4 ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO ! -------------

MIN_PCTFLO = PCTFLO ! PCT OF T-1 FLOW RETAINED IN T ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) PR_SUM = 0.0 N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR) = 1.0 ELSE ! opt 2 TADDDMD = NODE_DMD(NET,DEST) - & (MIN_PCTFLO * PRVNODE_DMD(NET,DEST)) IF (TADDDMD .LE. 0.0) THEN MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) ) TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST)) IF (CYCLE .EQ. 1) THEN WRITE(NGOERR,*) " MIN_PCTFLO = ",MIN_PCTFLO, &

"FOR DEST, YEAR = ", DEST,MODYR ENDIF ENDIF

IF (TADDDMD .GE. 0.0) THEN

! NET DMD INCREASES ! opt 4 ! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A) IF (NET .EQ. PKNET) THEN IF (SRC .GT. TNODES+SNODES) THEN ! storage CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) ELSE IF(SRC .LE. TNODES) THEN ! pipe CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR ELSE ! supply CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ELSE CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A) ENDIF ENDDOSUM_REMCAP = 0.0

DO A=ARC_1,ARC_2 IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** & ALPHAFAC ELSE PRV_REMCAP(A) = 0.0 ENDIF SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A) ENDDO

INVPR_SUM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A) IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (CUR_EFFCAP(NET,A).GT. 0.0)) THEN INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** ARC_GAMMAFAC(A)) ENDIF ENDDO

SUMSHR = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0) .AND. & (CUR_EFFCAP(NET,A).GT. 0.0)) THEN ADDSHR(A) = & (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM) !AAAA ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) * !AAAA* (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

ELSE ADDSHR(A) = 0.0 ENDIF SUMSHR = SUMSHR + ADDSHR(A) ENDDO ! opt 4 IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE ADDSHR(A) = ADDSHR(A) / SUMSHR ADDDMD(A) = ADDSHR(A) * TADDDMD NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A) ENDDO ELSE DO A=ARC_1,ARC_2 NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO ENDDO ENDIF ! opt 2 ! NET DMD DECREASES, SO MAKE SURE FLOWS AREN'T < 0 ! DEFINE SHR TO DECREASE FLOW AS P/(SUM P) ELSE

WRITE(NGOERR,*) " ERROR Z6NG: NEED TO CHECK CALC OF ", & "MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, & CURITR, CYCLE

DO A=ARC_1,ARC_2 PR_SUM = PR_SUM + (ARC_SHRPR(NET,A) ** GAMMAFAC) ENDDO

SUMSHR = 0.0 DO A=ARC_1,ARC_2 IF (PR_SUM .GT. 0.0) THEN ADDSHR(A) = (ARC_SHRPR(NET,A)**GAMMAFAC) / &

PR_SUM ELSEADDSHR(A) = 0.0

ENDIF SUMSHR = SUMSHR + ADDSHR(A) ENDDO IF (SUMSHR .GT. 0.0) THEN DO A=ARC_1,ARC_2 ADDSHR(A) = ADDSHR(A) / SUMSHR ENDDO ELSE DO A=ARC_1,ARC_2 ADDSHR(A) = 0.0 ENDDO ENDIF ! CHECK FOR NEGATIVE FLOW FLGSTOP = 0 DO A=ARC_1,ARC_2 FLGFLOW(A) = 1 ENDDO

DO WHILE (FLGSTOP .EQ. 0) FLOWNEG = 0.0 SUMSHR = 0.0

DO A=ARC_1,ARC_2 IF (FLGFLOW(A) .EQ. 1) THEN ADDDMD(A) = ADDSHR(A) * TADDDMD NEWFLOW(A) = (PRVFLOW(NET,A)*MIN_PCTFLO) + ADDDMD(A)

IF (NEWFLOW(A) .LT. 0.0) THEN FLOWNEG = FLOWNEG + NEWFLOW(A) NEWFLOW(A) = 0.0 ADDSHR(A) = 0.0 FLGFLOW(A) = 0 ELSE FLGFLOW(A) = 1 SUMSHR = SUMSHR + ADDSHR(A) ENDIF ENDIF ENDDO

IF (FLOWNEG .GE. 0.0) THEN FLGSTOP = 1 ELSE DO A=ARC_1,ARC_2 IF (FLGFLOW(A) .EQ. 1) THEN ADDSHR(A) = ADDSHR(A) / SUMSHR ENDIF ENDDO ENDIF ENDDO ! end DO while flgstop = 0

ENDIF ! end check for added net dmd > 0

DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST) ENDDO
ENDIF ! end check for single arc into node

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! X ! ! X ! USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES ! X ! ! X! STATUS: COMPLETE ! X ! ! X ! CALLED BY: NGDOWN_TREE ! X ! ! X ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! X SUBROUTINE XNGSHR_CALC(DEST,NET) ! X IMPLICIT NONE ! X ! X include 'parametr' ! x include 'ngparinc' ! x include 'ngtdminc' ! x include 'ngitminc' ! x ! X INTEGER*4 A ! COUNTERS ! X INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS ! X INTEGER*4 DEST ! NODE ON TREE (DEST NODE) ! X INTEGER*4 NET ! REPRESENTS PK,OP NETWORK ! X ! X REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS ! X ! X ! ------------- ! X ! X ARC_1 = ARC_LOOP(NET,DEST,1) ! X ARC_2 = ARC_LOOP(NET,DEST,2) ! X INVPR_SUM = 0.0 ! X ! X IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE ! X SHR(NET,ARC_1,MODYR) = 1.0 ! X ELSE ! X DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ! X IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN ! X INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC) ! X ENDIF ! X ENDDO ! X ! X DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. & (INVPR_SUM .GT. 0.0)) THEN ! X SHR(NET,A,MODYR) = MUFAC* SHR(NET,A,MODYR-1)+ (1.-MUFAC)* & (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM) ! X ELSE ! X SHR(NET,A,MODYR) = 0.0 ! X ENDIF ! X ENDDO ! X ENDIF ! X ! X RETURN ! X END ! X ! X ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS ! ! STATUS: UNDER CONSTRUCTION ! ! CALLED BY: NGDOWN_TREE ! ! FUNCTIONS USED: ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSHR_MTHCHK(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ncntrl'include 'ngparinc'

include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A,D,I ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE) INTEGER*4 CHNG, CHK, C ! FLAGS TO REDEFINE SHARES INTEGER*4 MAXFLG(ARCS) ! FLAG INDICATING MAX CAP ON ARC

REAL*4 TMTH_CAP REAL*4 TMTH_SHR REAL*4 TINIT_CAPADD REAL*4 INIT_CAPADD(ARCS) REAL*4 MTH_REDC REAL*4 MTH_CAP(ARCS) REAL*4 MTH_NETNOD(TNODES) REAL*4 MTHFLW(ARCS) REAL*4 MTH_CAPADD(NETWORK,ARCS) REAL*4 MTH_TCAPADD ! REAL*4 NEW_MTHCAP(NETWORK,ARCS) REAL*4 NEW_MTHCAP(ARCS) REAL*4 MTH_EXFLW REAL*4 T_MTHFLW REAL*4 CUR_PERCAP(ARCS) REAL*4 NEW_PERCAP(ARCS) REAL*4 PER_CAPADD(ARCS) REAL*4 PERFAC REAL*4 ALLOWBLD REAL*4 NEW_EXFLW REAL*4 NEWT_MTHFLW REAL*4 ADDFLW

REAL*4 MTH_MAXCAP(ARCS) REAL*4 TMTH_MAXCAP REAL*4 MTHDMD24 ! PKMTH demand at node 24 REAL*4 MTHSTR(STNODES)! PKMTH storage REAL*4 TMTH_STR ! total PKMTH storage REAL*4 WXBLD ! extra builds due to weather factor

INTEGER*4 W,V LOGICAL TMPSET/.TRUE./ ! -------------

IF (TMPSET) THEN TMPSET = .FALSE. ALLOWBLD = 1.0 IF (MODYR .LE. NOBLDYR) THEN WXBLD = 0.0 ELSE WXBLD = XBLD ENDIF ENDIF

TMTH_CAP = 0.0 ! INITIALIZE TOTAL PIPELINE MONTHLY CAP TMTH_SHR = 0.0 ! INITIALIZE TOTAL SHR TINIT_CAPADD = 0.0 ! INITIALIZE TOTAL PIPE CAP ADDITIONS

TMTH_MAXCAP = 0.0

IF (NET .EQ. PKNET) THEN PERFAC = PKSHR_YR ELSE PERFAC = 1.-PKSHR_YR ENDIFARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! REDUCE MONTHLY CONS BY MONTHLY SUP AND STR FLOWS MTH_REDC = 0.0 IF (NGDBGITR(4,7)) THEN write(ngoerr,*) "ATTN11: YR,ITR,DEST,NODE_DMD,MTH_CONS,%= ", & MODYR," ",CURITR," ",DEST," ",NODE_DMD(NET,DEST)," ", & MTH_CONS(NET,DEST)," ",MTH_CONS(NET,DEST)/NODE_DMD(NET,DEST) ENDIF

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .GT. TNODES+SNODES) THEN ! STORAGE MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &

NODE_DMD(NET,DEST) * SPERMTH(NET,DEST)) ELSE IF (SRC .GT. TNODES) THEN ! SUPPLY MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &

NODE_DMD(NET,DEST) * PPERMTH(NET,SRC-TNODES)) !by sup reg !! NODE_DMD(NET,DEST) * PPERMTH(NET,DEST)) !by ng reg

ELSE ! PIPELINE ARCS CUR_PERCAP(A) = PERFAC * CURPCAP(A,MODYR) NEW_PERCAP(A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST) ! don't use xbld here IF (NEW_PERCAP(A) .GT. CUR_PERCAP(A)) THEN ! ALLOWBLD=1 unless want to restrict blds PER_CAPADD(A) = ALLOWBLD * (NEW_PERCAP(A) - CUR_PERCAP(A)) ELSE PER_CAPADD(A) = 0.0 ENDIF

MTH_CAP(A) = PERMTH(NET) * (CUR_PERCAP(A) + PER_CAPADD(A)) TMTH_CAP = TMTH_CAP + MTH_CAP(A)

MTH_MAXCAP(A) = PERMTH(NET) * PERFAC * MAXPCAP(NET,A) TMTH_MAXCAP = TMTH_MAXCAP + MTH_MAXCAP(A)

TMTH_SHR = TMTH_SHR + SHR(NET,A,MODYR) ENDIF ENDDO ! PIPELINE ARCS MTH_NETNOD(DEST) = (MTH_CONS(NET,DEST) - MTH_REDC) * & (1. + WXBLD) ! weather impact on dmd

IF (MTH_NETNOD(DEST) .GE. (TMTH_MAXCAP+0.001)) THEN ! keep this write WRITE(NGOERR,30) DEST,modyr,curitr, & mth_netnod(dest),tmth_maxcap,tmth_cap 30 FORMAT (1X,'ATTN9: NGSHR_MTHCHK MAX CAP ERROR, dest=', &

I4,' year,itr= ',I4,I4,' mth_netnod(dest),tmth_maxcap,tmth_cap ', & 3F10.2) ENDIF

! IF CANADIAN NODE 24, REDEFINE STR PKMTH FACTOR (SPERMTH) IF (DEST .EQ. TNODES-LNGNODES) THEN ! Canadian node 24 ! IF (NGDBGITR(4,7)) THEN

WRITE(NGOERR,40) MTH_NETNOD(DEST), MTH_REDC, DEST, & modyr,curitr 40 FORMAT (1X,'ATTN10: NGSHR_MTHCHK MTH_NETNOD demand, ', &

'MTH_REDC ', 2F10.2, 'for region ', I4,' in year,itr ', 2I4) ! ENDIF

IF (ABS(MTH_NETNOD(DEST) / MTH_REDC) .GT. .01) THEN ! redefine str PKMTH factor TMTH_STR = 0.0 DO I=1,STNODESD = STR_2NODE(I)

A = NODE_2ARC(TNODES+SNODES+I,D) MTHSTR(I) = (SHR(NET,A,MODYR) * (1. +WXBLD) * & NODE_DMD(NET,D) * SPERMTH(NET,D)) TMTH_STR = TMTH_STR + MTHSTR(I) IF (D .EQ. TNODES-LNGNODES) THEN ! Canadian node 24 MTHDMD24 = MTH_NETNOD(D) ENDIF ENDDO DO I=1,STNODES D = STR_2NODE(I) SPERMTH(NET,D) = SPERMTH(NET,D) * & ((TMTH_STR + MTHDMD24) / TMTH_STR) IF (I .EQ. 14) THEN WRITE(NGOERR,50) D,SPERMTH(NET,D),MTHSTR(I),TMTH_STR 50 FORMAT (1X,'ATTN10: NGSHR_MTHCHK new SPERMTH for reg ', &

I4,' = ',F10.7,' MTHSTR= ',F10.2, ' TMTH_STR= ',F10.2) ENDIF IF (NGDBGITR(4,7)) THEN WRITE(NGOERR,*) "ATTN10: NGSHR_MTHCHK new SPERMTH for", & " reg ",D," = ",SPERMTH(NET,D)," MTHSTR= ",MTHSTR(I), & " TMTH_STR= ",TMTH_STR ENDIF ENDDO

ENDIF ENDIF

! TOTAL MONTHLY PIPELINE CAP ADDITIONS NEEDED MTH_TCAPADD = AMAX1( (MTH_NETNOD(DEST) - TMTH_CAP), 0.0 )

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS IF (TMTH_SHR .GT. 0.0) THEN MTHFLW(A) = MTH_NETNOD(DEST) * &

(SHR(NET,A,MODYR) / TMTH_SHR) ELSE MTHFLW(A) = 0.0 ENDIF INIT_CAPADD(A) = AMAX1( (MTHFLW(A) - MTH_CAP(A)), 0.0 ) TINIT_CAPADD = TINIT_CAPADD + INIT_CAPADD(A) ENDIF ENDDO

! SET NEW CAPACITY ALONG PIPELINE ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS IF (TINIT_CAPADD .GT. 0.0) THEN MTH_CAPADD(NET,A) = MTH_TCAPADD * & (INIT_CAPADD(A) / TINIT_CAPADD) ELSE MTH_CAPADD(NET,A) = 0.0 ENDIF NEW_MTHCAP(A) = MTH_CAP(A) + MTH_CAPADD(NET,A)

IF (NGDBGITR(4,7)) THEN WRITE(NGOERR,22) MODYR,CURITR,SRC,DEST, & MTH_CAP(A),NEW_MTHCAP(A),MTH_MAXCAP(A) ENDIF 22 FORMAT(' ATTN22: YR,ITR,SRC,DEST,MTHCAP,NEW_,MAX_= ', &

I4,I4,I4,I4,3F10.3)

ENDIFENDDO

! CHECK IF NEW_MTHCAP > MTH_MAXCAP

CALL NGFLW_MTHMAX(1,NET,DEST,NEW_MTHCAP,MTH_MAXCAP)

! CHECK IF MONTHLY FLOWS EXCEED MONTHLY PK CAP AND REALLOCATE

CALL NGFLW_MTHMAX(2,NET,DEST,MTHFLW,NEW_MTHCAP)

! ADD MONTHLY FLOWS TO MONTHLY SRC PK DEMAND NODE ! AND ADD EXTRA CAPACITY AS CONTINGENCY

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS MTH_CONS(NET,SRC) = MTH_CONS(NET,SRC) + & MTHFLW(A) /(1. + WXBLD) ! rmv weather impact on dmd ENDIF ! stores new annual cap in opnet position IF (SRC .LE. DNODES) THEN ! PIPELINE ARCS IF (NET .EQ. PKNET) THEN MAXPCAP(OPNET,A) = NEW_MTHCAP(A) / (PERMTH(NET)*PERFAC) IF (MAXPCAP(OPNET,A) .GT. MAXPCAP(PKNET,A)) THEN MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A) ENDIF ENDIF ENDIF ENDDO

RETURN END

! ========================================================== ! ! CHECK IF MAXIMUM FLOW OR CAPACITY IS EXCEEDED AND REALLOCATE ! ! ==========================================================

SUBROUTINE NGFLW_MTHMAX(ID,NET,DEST,FLW,CAP) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc'

INTEGER*4 ID, NET, DEST, SRC INTEGER*4 A, ARC_1, ARC_2 INTEGER*4 C, CHNG, CHK INTEGER*4 MAXFLG(ARCS) INTEGER*4 CNT ! count number of pipeline arcs into node

REAL*4 FLW(ARCS) REAL*4 CAP(ARCS) REAL*4 ADDFLW REAL*4 EXFLW REAL*4 T_FLW REAL*4 NEW_EXFLW REAL*4 NEWT_FLW ! ------------

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)CNT=0

DO A=ARC_1,ARC_2 ! COUNT NUM OF PIPELINE ARCS INTO NODE SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN CNT = CNT+1 ENDIF ENDDO

IF (CNT .LE. 1) THEN ! IF ONLY 1 PIPELINE ARC, CANNOT REALLOCATE RETURN ENDIF

EXFLW = 0.0 T_FLW = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS IF (FLW(A) .GE. CAP(A)) THEN EXFLW = EXFLW + (FLW(A)-CAP(A)) FLW(A) = CAP(A) MAXFLG(A) = 1 ELSE T_FLW = T_FLW + FLW(A) MAXFLG(A) = 0 ENDIF ENDIF ENDDO

C = 1 CHNG = 1 DO WHILE ((CHNG .EQ. 1) .AND. (C .LE. 20)) CHK = 0

NEW_EXFLW = 0.0 NEWT_FLW = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS IF (MAXFLG(A) .EQ. 0) THEN ADDFLW = EXFLW * (FLW(A) / T_FLW) IF (ADDFLW .GE. (CAP(A) - FLW(A))) THEN CHK = 1 MAXFLG(A) = 1 NEW_EXFLW = NEW_EXFLW + (ADDFLW - &

(CAP(A) - FLW(A))) FLW(A) = CAP(A) ELSE FLW(A) = FLW(A) + ADDFLW NEWT_FLW = NEWT_FLW + FLW(A) ENDIF

ENDIF ENDIF ENDDO

EXFLW = NEW_EXFLW T_FLW = NEWT_FLW CHNG = CHK C = C+1 ENDDO

IF (C .GT. 20) THEN WRITE(NGOERR,*) "ATTN8: MTH CAP REALLC INCOMPLETE FOR ", & MODYR, CURITR, " NET= ",NET, " DEST= ",DEST," ID= ",ID ENDIFRETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP ! ! STATUS: COMPLETE ! ! CALLED BY: NGDOWN_TREE ! ! FUNCTIONS USED: NGSET_MAXFLO ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSHR_MAXCHK(DEST,NET) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE) INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD) INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR REAL*4 SUMMAX ! TOTAL SHARES AT MAX SHR REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

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

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

TMAXFLO = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) OLDFLG(A) = 0. MAXFLG(A) = 0. MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST) ELSE SHRMAX(A) = SHR(NET,A,MODYR) * 1.2 ! temp ???????? OK? ENDIF TMAXFLO = TMAXFLO + MAXFLO(NET,A) ENDDO

IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN ! DMD < TMAXFLO CHNG = 1 DO WHILE (CHNG .EQ. 1) CHK = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW MAXFLG(A) = 1IF (MAXFLG(A) .NE. OLDFLG(A)) THEN CHK = 1 OLDFLG(A) = MAXFLG(A) ENDIF ENDIF ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS SUMMAX = 0.0 SUMREM = 0.0 SUMSHR = 0.0

CNT0 = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN CNT0 = CNT0 + 1 SUMSHR = SUMSHR + SHR(NET,A,MODYR) ELSE SUMMAX = SUMMAX + SHR(NET,A,MODYR) ENDIF ENDDO SUMREM = 1. - (SUMSHR+SUMMAX) ! DISTRIBUTE OVER UNCONSTR ARCS DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN IF (SUMSHR .GT. 0.0) THEN SHR(NET,A,MODYR) = (1. + (SUMREM/SUMSHR)) * & SHR(NET,A,MODYR) ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0) ENDIF ENDIF ENDDO ELSE CHNG = 0 ENDIF ENDDO

ELSE ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO !CCC BKSTOP_FLG = 1

DO A=ARC_1,ARC_2 SHR(NET,A,MODYR) = SHRMAX(A) ENDDO

WRITE(NGOERR,100) & ! ATTN MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), & TMAXFLO, RBKSTOP_PADJ(NET,DEST) ENDIF

100 FORMAT(1X,'ATTN4--BKSTOP: YR,CYC,NET,NODE= ',I4,I3,I2,I3, &

' BKSTOP,DMD,MAX,PADJ= ', 3F10.4,F7.3)

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP ! ! STATUS: COMPLETE ! ! CALLED BY: NGDOWN_TREE! ! FUNCTIONS USED: NGSET_MAXFLO ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE ZNGSHR_MAXCHK(DEST,NET,ADDSHR) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE) INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD) INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE REAL*4 ADDSHR(ARCS) ! SHARES OF FLOW ADDED TO T-1 ! -------------

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

TMAXFLO = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) OLDFLG(A) = 0. MAXFLG(A) = 0. MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST) ELSE SHRMAX(A) = SHR(NET,A,MODYR) * 1.2 ! temp ???????? OK? ENDIF TMAXFLO = TMAXFLO + MAXFLO(NET,A) ENDDO

IF (NODE_DMD(NET,DEST) .LE. TMAXFLO+.001) THEN ! DMD < TMAXFLO

CHNG = 1 DO WHILE (CHNG .EQ. 1) CHK = 0 SUMREM = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN SUMREM = SUMREM + (SHRMAX(A) - SHR(NET,A,MODYR)) SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW MAXFLG(A) = 1 IF (MAXFLG(A) .NE. OLDFLG(A)) THEN CHK = 1 OLDFLG(A) = MAXFLG(A) ENDIF ENDIF ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS SUMSHR = 0.0CNT0 = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN CNT0 = CNT0 + 1 SUMSHR = SUMSHR + ADDSHR(A) ENDIF ENDDO

! DISTRIBUTE OVER UNCONSTR ARCS DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS IF (MAXFLG(A) .EQ. 0) THEN IF (SUMSHR .GT. 0.0) THEN SHR(NET,A,MODYR) = (SUMREM*ADDSHR(A)/SUMSHR) + & SHR(NET,A,MODYR) ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0) ENDIF ENDIF ENDDO ELSE CHNG = 0 ENDIF ENDDO ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE ! ! STATUS: COMPLETE ! ! CALLED BY: NGSHR_MAXCHK ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION NGSET_MAXFLO(NET,A) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 A ! COUNTER INTEGER*4 SRC ! NODE ON TREE (SOURCE) INTEGER*4 DEST ! NODE ON TREE (DESTINATION)

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION REAL*4 XCAP ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW REAL*4 DELXCAP ! EXTRA CAP BUILD DUE TO WEATHER

REAL*4 XNGSET_MAXFLO !utz ! ---------

NGSET_MAXFLO = XNGSET_MAXFLO(NET,A) !utz RETURN !utz

SRC = ARC_2NODE(A,1) DEST= ARC_2NODE(A,2)IF (SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARC

PKFAC = PKUTZ(A) OPFAC = OPUTZ(A) ! NOTE: = 0.0 ELSE ! PIPELINE OR SUPPLY ARC PKFAC = PKSHR_YR * PKUTZ(A) OPFAC = (1.-PKSHR_YR) * OPUTZ(A) ENDIF

IF (NET .EQ. PKNET) THEN ! PEAK NGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC ELSE ! OFFPEAK IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR. & ((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN ! SUPPLY (NO LNG)-or- FLORIDA ! NO CURPCAP FOR SUPPLY MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

ELSE ! PIPE AND STORAGE XCAP = FLOW(PKNET,A) / PKFAC IF (XCAP .GT. CURPCAP(A,MODYR)) THEN MAXPCAP(OPNET,A) = XCAP ELSE MAXPCAP(OPNET,A) = CURPCAP(A,MODYR) ENDIF ENDIF NGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE ! ! STATUS: used with monthly calculation of cap adds ! ! CALLED BY: NGSHR_MAXCHK ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION XNGSET_MAXFLO(NET,A) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 A ! COUNTER INTEGER*4 SID ! NODE ON SUPPLY COUNT (1-97) INTEGER*4 LID ! NODE ON LNG SUPPLY COUNT (1-3) INTEGER*4 SRC ! NODE ON TREE (SOURCE) INTEGER*4 DEST ! NODE ON TREE (DESTINATION)

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION

REAL*4 XCAP ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW REAL*4 DELXCAP ! EXTRA CAP BUILD DUE TO WEATHER REAL*4 OPCAP ! PLACEHOLDER FOR NEW ANNUAL CAP ! ---------

SRC = ARC_2NODE(A,1) DEST= ARC_2NODE(A,2)IF (SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARC

PKFAC = PKUTZ(A) OPFAC = OPUTZ(A) ! NOTE: = 0.0 ELSE ! PIPELINE OR SUPPLY ARC PKFAC = PKSHR_YR * PKUTZ(A) OPFAC = (1.-PKSHR_YR) * OPUTZ(A) ENDIF

SID = SRC-TNODES ! SUPPLY NODE COUNT (1-97) IF (SID .GE.FSRGN(14) .AND. SID .LE.FSRGN(14)+NSRGN(14)-1) THEN ! LNG SUPPLY !JBEMAX LID = SID - FSRGN(14)+1 ! LNG SUPPLY COUNT (1-3)

XNGSET_MAXFLO = MAXPLNG(LID,NET,MODYR) !JBEMAX ELSE !JBEMAX IF (NET .EQ. PKNET) THEN ! PEAK XNGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC ELSE ! OFFPEAK IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR. & ((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN ! SUPPLY -or- FLORIDA ! NO CURPCAP FOR SUPPLY MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A) ! storage, imports, or nobldyr ELSE XCAP = FLOW(PKNET,A) / PKFAC IF (XCAP .GT. CURPCAP(A,MODYR)) THEN OPCAP = XCAP ELSE OPCAP = CURPCAP(A,MODYR) ENDIF !xutz IF ((SRC.LE.DNODES) .AND.(MAXPCAP(OPNET,A).GT.OPCAP)) THEN !xutz WRITE(NGOERR,60) MODYR,SRC,DEST,MAXPCAP(OPNET,A),OPCAP !xutz 60 FORMAT(1X,'XNGSET_MAXFLO: YR,SRC,DEST,MAX,OPCAP', & !xutz

3I5,2F10.2) !xutz CONTINUE ! use value set in NGSHR_MTHCHK !xutz ELSE !xutz MAXPCAP(OPNET,A) = OPCAP ENDIF ENDIF XNGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC ENDIF ENDIF !JBEMAX

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! CHECK CONVERGENCE ON SUPPLY PRICE ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! CALLS : NGSET_SUPPR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGCHK_CONVNG IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc'

REAL*4 DELTA ! DIFFERENCE BTWN CURRENT & PREV SUP PRINTEGER*4 N,S ! COUNTERS

INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP) INTEGER*4 CFLG ! CONVERGE FLAG FOR CYCLING UP/DOWN TREE

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

DO NET=1,NETWORK DO N=1,NODES NODE_ENDPR(NET,N) = 0.0 NODE_SHRPR(NET,N) = 0.0 ENDDO ENDDO

DO NET=1,NETWORK DO S=1,SNODES N = TNODES + S IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N) ENDDO ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

CALL NGSET_SUPPR

! SET SCALE FACTOR FOR L48 & OFFSHORE WELLHEAD PRICE

IF (MODYR .GT. EHISYR) THEN CALL NGSTEO_BENCHWPR ENDIF

! CHECK FOR CONVERGENCE IF CYCLE > 1

DO NET=1,NETWORK DO S=1,SNODES IF (SUPARRAY(S).EQ.1) THEN PSUP_CNVG(NET,S) = 1 QSUP_CNVG(NET,S) = 1 ENDIF ENDDO ENDDO

CFLG = 1

IF (CYCLE .GT. 1) THEN

DO NET=1,NETWORK DO S=1,SNODES ! LOOP OVER SUPPLY NODES IF (SUPARRAY(S).EQ.1) THEN DELTA = ABS(NODE_PSUP(NET,S) - NODE_PSUPPREV(NET,S)) / &

NODE_PSUPPREV(NET,S) IF (DELTA .LE. PSUP_DELTA) THEN PSUP_CNVG(NET,S) = 1 ELSE PSUP_CNVG(NET,S) = 0 QSUP_CNVG(NET,S) = 0 CFLG = 0 IF (NODE_QSUP(NET,S) .LE. (QSUP_SMALL*SHRYR(NET))) THEN DELTA = ABS(NODE_QSUP(NET,S)-NODE_QSUPPREV(NET,S)) / &

NODE_QSUPPREV(NET,S) IF (DELTA .LE. QSUP_DELTA) THEN QSUP_CNVG(NET,S) = 1 CFLG = 1 ENDIF ENDIF ENDIFIF (CFLG.EQ.0) GO TO 100

ENDIF ENDDO ENDDO DO NET=1,NETWORK DO N=1,TNODES IF (BKSTOP(NET,N) .GT. 0.0) THEN CFLG = 0 ENDIF ENDDO ENDDO

100 CONTINUE

! IF NOT CONVERGED, SET NEW RELAXED SUPPLY QTY AND ! GET NEW WELLHEAD PRICE BEFORE GOING UP TREE

IF (CFLG .EQ. 0) THEN !CCC IF ((CFLG .EQ. 0) .OR. (BKSTOP_FLG .EQ. 1)) THEN !CCC IF (BKSTOP_FLG .EQ. 1) THEN !CCC BKSTOP_PADJ = BKSTOP_PADJ + 1. !CCC ENDIF

CNVGFLG = 0 DO NET=1,NETWORK DO S=1,SNODES ! LOOP OVER SUPPLY NODES !CCC IF (PSUP_CNVG(NET,S).EQ.0 .AND. QSUP_CNVG(NET,S).EQ.0) THEN

IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = QSUP_WT * NODE_QSUP(NET,S) + &

(1.-QSUP_WT)* NODE_QSUPPREV(NET,S) !CCC ENDIF

ENDDO ENDDO

CALL NGSET_SUPPR IF (MODYR .GT. EHISYR) THEN CALL NGSTEO_BENCHWPR ! SET SCALE FAC FOR ON/OFFSHORE WELLHEAD PRICE ENDIF

ELSE CNVGFLG = 1 WRITE(NGOERR,*) 'CONVERGED ON CYCLE= ',CYCLE, & ' ITR= ',CURITR,' YEAR= ',MODYR, ' ! ATTN4' ENDIF ENDIF

DO NET=1,NETWORK DO S=1,SNODES IF (SUPARRAY(S).EQ.1) THEN N = TNODES + S NODE_ENDPR(NET,N) = NODE_PSUP(NET,S) NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S) NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S) ENDIF ENDDO ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! USE SUPPLY CURVES AND QTY TO SET WELLHEAD PRICES ! ! STATUS: COMPLETE !! CALLED BY: NGTDM_ITM ! ! FUNCTIONS USED: NGSUP_PR ! ! NOTES: MAY WANT TO CHANGE PK/OP ALGORITHM ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGSET_SUPPR IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc' include 'nghistinc' include 'ngtdminc'

INTEGER*4 N,S,M,MX ! COUNTERS INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP)

REAL*4 PKPR, OPPR ! TEMP PK,OP SUP PRICES REAL*4 PQ ! SUM OF P*Q REAL*4 SPAVG(SNODES) ! QTY WEIGHTED AVG OF PK & OP REAL*4 FSF ! FINE SCALING FACTOR REAL*4 SQSUP(NETWORK) ! SEASONAL SUPPLY QTY REAL*4 SPSUP(NETWORK) ! SEASONAL SUPPLY PRICE REAL*4 ANNSUP ! EQUIVALENT ANNUAL SUPPLY FROM PK,OP SUPPLY REAL*4 NGSUP_PR ! SUPPLY CURVE FUNCTION REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION REAL*4 NGPRCLNG ! LNG SUPPLY CURVE FUNCTION REAL*4 QLAGTOT(NETWORK,NLNGCRV) ! LNG IMPORTS LAST YEAR, EAST AND WEST REAL*4 TOTQ(NETWORK,NLNGCRV) ! IMPORT LEVELS IN EAST AND WEST (LAST YEAR, THIS YEAR) REAL*4 MEXLNGTOT ! TOTAL MEXICO LNG IMPORTS ON GIVEN COAST REAL*4 SH ! TEMPORARY HOLD SEASONAL MEXICO SHARE REAL*4 DUMMY ! DUMMY ARGUMENT WHEN NOT NEEDED BY FUNCTION

! ---------

PKFAC = PKSHR_YR OPFAC = (1.-PKSHR_YR)

DO S=1,SNODES ! VARIABLE SUPPLY, 1-20,21 PQ = 0.0 RPSHIFT(S) = 0.0

IF(SUPTYPE(S).NE.14 .AND. FIXLNGFLG) THEN PSUP(S) = 0.0 QSUP(S) = 0.0 ENDIF

IF (SUPARRAY(S).EQ.1) THEN QSUP(S) = NODE_QSUP(PKNET,S) + NODE_QSUP(OPNET,S) N = S + TNODES ! NODE ID IF(SUPTYPE(S).NE.14) THEN ! NON-LNG PSUP(S) = NGSUP_PR('Q',QSUP(S),S) !*FUNCTION IF (MODYR .LE. EHISYR) THEN RPSHIFT(S) = HPSUP(S,MODYR) - PSUP(S) HIST_RPSHIFT(S,MODYR) = RPSHIFT(S) PSUP(S) = HPSUP(S,MODYR) ENDIF IF (S.EQ.18 .AND. (ZOGRESNG(18).LE.0.0 .OR. ZOGPRRNG(18).LE.0.0)) PSUP(S) = PSUP(8) - 0.15

DO NET=1,NETWORK IF (NET .EQ. PKNET) THEN ! PKANNSUP = NODE_QSUP(NET,S) / PKFAC ELSE ! OP ANNSUP = NODE_QSUP(NET,S) / OPFAC ENDIF SQSUP(NET) = NODE_QSUP(NET,S) SPSUP(NET) = NGSUP_PR('Q',ANNSUP,S) !*FUNCTION PQ = PQ + SPSUP(NET) * SQSUP(NET) ENDDO

IF (QSUP(S) .GT. 0.) THEN SPAVG(S) = PQ / QSUP(S) ELSE SPAVG(S) = PSUP(S) ENDIF FSF = PSUP(S) / SPAVG(S)

DO NET=1,NETWORK NODE_PSUP(NET,S) = SPSUP(NET) * FSF ENDDO

ELSE ! LNG M = S - FSRGN(14) + 1

IF (QSUP(S) .GT. 0.0) THEN PKSHR_PROD(S) = NODE_QSUP(PKNET,S)/QSUP(S) !DEFINE LNG SHARE HERE? ELSE PKSHR_PROD(S) = PKSHR_YR ENDIF

IF (MODYR.LE.LHISYR) THEN DO NET=1,NETWORK NODE_PSUP(NET,S) = HPLNG(NET,4,MODYR) ! GULF OF MEXICO PRICE PSUP(S) = HPSUP(S,MODYR) ENDDO ELSE ! forcast

IF (LNGCRVOPT.EQ.6) THEN ! TOTAL N.AMER CURVE SQSUP = 0.0 ANNSUP = 0.0

DO NET=1,NETWORK IF (NET.EQ.PKNET) THEN SH = PKSHR_EMEX ELSE SH = 1.-PKSHR_EMEX ENDIF DO MX=1,NUMREG SQSUP(NET) = SQSUP(NET) + MEXLNG(MX,MODYR) * SH ANNSUP = ANNSUP + MEXLNG(MX,MODYR) * SH ENDDO

DO N=FSRGN(14),FSRGN(14)+NSRGN(14)-1 ! ADD EAST AND WEST SQSUP(NET) = SQSUP(NET) + NODE_QSUP(NET,N) ANNSUP = ANNSUP + NODE_QSUP(NET,N) ENDDO ENDDO
! if using seasonal curves

DO NET=1,NETWORK NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,SQSUP(NET),'Q',DUMMY) !*LNG FUNCTION (LAG NOT USED) PQ = PQ + ( NODE_PSUP(NET,S) * SQSUP(NET) ) ENDDO IF (ANNSUP .GT. 0.) THENSPAVG(S) = PQ / ANNSUP ELSE SPAVG(S) = PSUP(9) ENDIF PSUP(S) = SPAVG(S)

! when have annual curves ! ! PSUP(S) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY) !*LNG FUNCTION (LAG NOT USED) ! DO NET=1,NETWORK ! IF (NET .EQ. PKNET) THEN ! PK ! ANNSUP = SQSUP(NET) / PKFAC ! ELSE ! OP ! ANNSUP = SQSUP(NET) / OPFAC ! ENDIF ! SPSUP(NET) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY) !*LNG FUNCTION (LAG NOT USED) ! PQ = PQ + ( SPSUP(NET) * SQSUP(NET) ) ! ENDDO ! ! IF ((SQSUP(PKNET) + SQSUP(OPNET)) .GT. 0.) THEN ! SPAVG(S) = PQ / (SQSUP(PKNET) + SQSUP(OPNET)) ! ELSE ! SPAVG(S) = PSUP(S) ! ENDIF ! FSF = PSUP(S) / SPAVG(S) ! ! DO NET=1,NETWORK ! NODE_PSUP(NET,S) = SPSUP(NET) * FSF ! ENDDO

ELSE

TOTQ(PKNET,M) = NODE_QSUP(PKNET,S) TOTQ(OPNET,M) = NODE_QSUP(OPNET,S) DO NET=1,NETWORK IF (NET.EQ.PKNET) THEN SH = PKSHR_EMEX ELSE SH = 1.-PKSHR_EMEX ENDIF

QLAGTOT(NET,M) = NODE_QSUPPREV(NET,S) IF (M.EQ.1) THEN MEXLNGTOT = (MEXLNG(2,MODYR) + MEXLNG(4,MODYR)) * SH ELSEIF (M.EQ.2) THEN MEXLNGTOT = (MEXLNG(1,MODYR) + MEXLNG(3,MODYR) + MEXLNG(5,MODYR)) * SH ENDIF QLAGTOT(NET,M) = QLAGTOT(NET,M) + MEXLNGTOT TOTQ(NET,M) = TOTQ(NET,M) + MEXLNGTOT

NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,TOTQ(NET,M),'Q',QLAGTOT(NET,M)) !*LNG FUNCTION

PQ = PQ + NODE_PSUP(NET,S) * TOTQ(NET,M) !WITH ADJ FOR MEXICO, CORRECT? ENDDO

IF ((TOTQ(PKNET,M)+TOTQ(OPNET,M)).GT.0.0) THEN PSUP(S)= PQ / (TOTQ(PKNET,M)+TOTQ(OPNET,M)) ELSE PSUP(S)= 1.0 ! NOT NECESSARILY BEST FALLBACK ENDIF ENDIF ENDIF ENDIFENDIF

ENDDO

RETURN END

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

! PLACEHOLDER FOR SUPPLY CURVE FUNCTIONS ! The new OGSM supply curves will be estimating equations ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGSET_SUPPR ! ! NOTES: -SUP CRV INCLUDES PROD FOR L&P ! -INCREASE SUP QTY BY L&P % BEFORE USING SUP CRV ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

REAL FUNCTION NGSUP_PR(INVAL,VALUE,IREG) IMPLICIT NONE include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc' include 'ngsteoinc' include 'ogglobal'

! DETERMINES LEVEL OF PRODUCTION OR WELLHEAD PRICE GIVEN A PRICE OR ! A LEVEL OF DESIRED PRODUCTION (RESPECTIVELY) FOR THE REQUESTED ! NGTDM/OGSM REGION (ONSHORE, OFFSHORE, CANADA: 1-21)

INTEGER*4 IREG ! NGTDM/OGSM REGION (1-21) INTEGER*4 NREG ! NGTDM REGION (1-12) INTEGER*4 IVREG ! NGTDM/OGSM REGION for variable supply INTEGER*4 I,J ! COUNTER INTEGER*4 N,S ! COUNTER INTEGER*4 NG_NREG ! FUNCTION: MAPS SUP REG ID TO NG REG INTEGER*4 NG /2/ ! temp: kevsup INTEGER*4 R INTEGER*4 ICNT ! COUNTER

REAL*4 QBASE ! REFERENCE QUANTITY POINT REAL*4 PBASE ! REFERENCE PRICE POINT REAL*4 XQBASE ! RESERVES*(P/R) REAL*4 XPBASE ! PRICE ASSOCIATED W/XQBASE REAL*4 AQBASE ! QUANTITY AT PERCENT BELOW XQBASE REAL*4 APBASE ! PRICE ASSOCIATED W/AQBASE REAL*4 BQBASE ! QUANTITY AT PERCENT ABOVE XQBASE REAL*4 BPBASE ! PRICE ASSOCIATED W/BPBASE REAL*4 CQBASE ! QUANTITY AT PERCENT BELOW AQBASE REAL*4 CPBASE ! PRICE ASSOCIATED W/CQBASE REAL*4 DQBASE ! QUANTITY AT PERCENT ABOVE BQBASE REAL*4 DPBASE ! PRICE ASSOCIATED W/DPBASE

REAL*4 QVAR ! TEMPORARY HOLDING ARRAY REAL*4 MIN_NA ! MINIMUM ALLOWED NA PRODUCTION REAL*4 VALUE ! INPUT PRICE OR QUANTITY REAL*4 FIXSUP ! "FIXED" SUPPLY QUANTITY REAL*4 ELAS ! SUPPLY CURVE "ELASTICITY" CHARACTER*1 INVAL ! CHARACTER INDICATING IF THE INPUT ! VALUE IS A PRICE OR QUANTITY REAL*4 QSHFT ! SHIFT CN SUPPLY CURVE (TEMP CODE)REAL*4 X ! HOLDS INTERMEDIATE VALUE

REAL*4 PRCIN ! INPUT PRICE ADJUSTED REAL*4 INITINP4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=P REAL*4 INITINQ4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=Q REAL*4 PRRLAG(20) ! PREVIOUS YEAR'S P/R RATIO REAL*4 WPRLAG(20) ! PREVIOUS YEAR'S WELLHEAD PRICE REAL*4 NEWVAL ! P/R RATIO FOR OPTION 2 REAL*4 PERCNT ! PCT L&P AFTER SCALING REAL*4 REG_CNST(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST1(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST2(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST3(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST4(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST5(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 REG_CNST6(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC REAL*4 BETA1,BETA2,BETA3,TMPUS REAL*4 CNC,CNRHO,CNB1,CNPRLAG,TMPCAN,CNDL REAL*4 AVGWOP, AVGNGP, POST2000 REAL*4 HDD, HDDLAG, L48_RA, L48_PRD, UGRSHR, REPRATE, ONCONVSHR, UGRRESSHR, UGRRESSHRLAG REAL*4 A1, B1, B2, B3, B4, B5, RHO REAL*4 Z1,Z2,Z3,Z4,Z5,Z6,Z7 ! EPA ADDED VARIABLES REAL*4 U_PROD_CONV(17) REAL*4 U_PROD_TIGHT(17) REAL*4 U_PROD_SHALE(17) REAL*4 U_PROD_CBM(17) REAL*4 NG_REDUCT_NEW REAL*4 OIL_WELLS_TOT REAL*4 CONV_WELLS_TOT REAL*4 TIGHT_WELLS_TOT REAL*4 SHALE_WELLS_TOT REAL*4 CBM_WELLS_TOT

! 1 2 3 4 5 6 7 8 9 10 ! EM4 TRACK -- keep here DATA REG_CNST /0.165,0.250,0.187,0.147,0.178,0.235,0.191,0.174,0.169,0.175, & ! AEO2002: P0=f(PGASLAG,WOP) change in ngtdm too 0.176,0.154,0.167,0.130,0.144,0.144,0.166,0.165,0.185,0.194,0.154/ ! change in ngtdm too DATA REG_CNST1 /0.000000,1.22073,0.944568,0.644145,0.848594,1.22073,0.917775,0.839626,0.799027,0.818277,& ! same form as AEO2002

0.837841,0.667143,0.760292,0.00000,0.63307,0.633293,0.842891,0.000000,0.873371,1.040223,& ! parameters reestimated 0.427865/ ! 9/07/02 DATA REG_CNST2 /-1.00000,-2.60565,-1.90727,-2.63350,-2.82434,-2.96152,-2.69612,-2.17580,-1.78278,-2.08644 , & ! Kevin's supply curve

-2.08877,-2.57941,-2.01510,-1.00000,-1.70728,-2.62790,-2.28963,-1.00000,-1.58386,-2.97082, & ! August 2002 -1.00000/ DATA REG_CNST3 /0.00000,6.30131,5.11757,5.83751,6.42938,7.04815,6.50180,5.24769,4.73239,5.21296,& ! P0=f(PR)

5.28422,6.06245,5.33154,0.00000,4.43217,6.04844,4.99544,0.00000,4.29734,6.19401,& ! 7/06/05 5.51554/ DATA REG_CNST4 /0.00000,6.12480,5.01729,5.85840,6.49504,6.84805,6.30017,5.25215,4.57664,5.01917,& !P0=f(PR)

5.12463,6.00357,4.87346,0.00000,4.34634,6.13117,4.88606,0.00000,4.19316,6.21324,& ! 7/06/05 5.51554/ DATA REG_CNST5 /0.00000,4.69550,3.56578,4.43286,5.08061,5.43386,4.87937,3.80729,3.11726,3.57019,& ! P0=f(PR)

3.67787,4.58168,3.42322,0.00000,2.88471,4.71196,3.43140,0.00000,2.72364,4.78780,& ! 7/06/05 4.08533/ DATA REG_CNST6 /0.000000,-11.9200,-12.0374,-12.0671,-12.4173,-11.8249,-12.0920,-12.0038,-11.6418,-11.7450 ,&

-11.8647,-11.7754,-12.9530,0.000000,-12.1479,-11.8890,-12.1491,0.000000,-11.7204,-12.4344, & -11.7829/

!------------------
QSHFT= 0.0 ! temp code (not used now)

! SET REPLACEMENT RATE AND UNCONVENTIONAL GAS SHARE IF (MODYR.GT.EHISYR) THEN L48_PRD = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1) & + oogqngrep(4,curiyr-1) + oogqngrep(6,curiyr-1))

L48_RA = 0. DO R=1,20 L48_RA = L48_RA + ZOGRADNGLAG1(r) ENDDO

REPRATE = L48_RA / L48_PRD
UGRSHR = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1)) & / L48_PRD

onconvSHR = oogqngrep(4,curiyr-1) / L48_PRD UGRRESSHRLAG = (oOGNGRSV(1,curiyr-1)+oOGNGRSV(2,curiyr-1)+oOGNGRSV(3,curiyr-1)) &

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

/ (oOGNGRSV(9,curiyr)) * 100.

IF (MODYR.EQ.EHISYR+1) THEN HDDLAG = 4524 ! HDD from 9/2009 STEO HDD = 4475. ! OEXSPEND(1,curiyr) = 1288. ! OEXSPEND(2,curiyr) = 67555752. ELSEIF (MODYR.EQ.EHISYR+2) THEN HDDLAG = HDD HDD = 4478. ! OEXSPEND(1,curiyr) = 1204. ! OEXSPEND(2,curiyr) = 59013208. ELSE HDDLAG = HDD HDD = 4237. ENDIF

ELSE REPRATE = 0. UGRSHR = 0. ENDIF

! SET VARIABLES WHICH DON'T CHANGE BASED ON VALUE COMING IN! NREG = NG_NREG(IREG) ! FUNCTION MAPPING SUP ID TO NG ID

IVREG=VNODES(IREG) NREG = MAP_NG(IREG) IF(IREG.EQ.SNODES-lSNODES-3) NREG=13 PERCNT = PCTLP(NREG) * SCALE_LP(MODYR)

IF (MODYR .LE. EHISYR) THEN XQBASE = QSUP(IREG) / (1.-PERCNT) ! w/ L&P ELSE XQBASE = ZOGRESNG(IREG) * ZOGPRRNG(IREG) ! w/ L*P ENDIF

! EPA CODE MODIFICATION FOR RIA NG_REDUCT_NEW = 0 OIL_WELLS_TOT = 0 CONV_WELLS_TOT = 0 TIGHT_WELLS_TOT = 0 SHALE_WELLS_TOT = 0 CBM_WELLS_TOT = 0

IF (IREG.LE.17 .and. CURIYR.GE.31) THEN

! NUMBER OF WELLS OF EACH TYPE

OIL_WELLS_TOT = oWELLSL48(2,1,1) + oWELLSL48(2,2,1) + oWELLSL48(2,3,1) &

+ oWELLSL48(2,4,1) + oWELLSL48(2,5,1) + oWELLSL48(2,6,1) & + oWELLSL48(2,1,2) + oWELLSL48(2,2,2) + oWELLSL48(2,3,2) & + oWELLSL48(2,4,2) + oWELLSL48(2,5,2) + oWELLSL48(2,6,2)

CONV_WELLS_TOT = oWELLSL48(2,1,3) + oWELLSL48(2,2,3) + oWELLSL48(2,3,3) &

+ oWELLSL48(2,4,3) + oWELLSL48(2,5,3) + oWELLSL48(2,6,3) & + oWELLSL48(2,1,4) + oWELLSL48(2,2,4) + oWELLSL48(2,3,4) & + oWELLSL48(2,4,4) + oWELLSL48(2,5,4) + oWELLSL48(2,6,4)

TIGHT_WELLS_TOT = oWELLSL48(2,1,5) + oWELLSL48(2,2,5) + oWELLSL48(2,3,5) &

+ oWELLSL48(2,4,5) + oWELLSL48(2,5,5) + oWELLSL48(2,6,5)

SHALE_WELLS_TOT = oWELLSL48(2,1,6) + oWELLSL48(2,2,6) + oWELLSL48(2,3,6) &

+ oWELLSL48(2,4,6) + oWELLSL48(2,5,6) + oWELLSL48(2,6,6)

CBM_WELLS_TOT = oWELLSL48(2,1,7) + oWELLSL48(2,2,7) + oWELLSL48(2,3,7) &

+ oWELLSL48(2,4,7) + oWELLSL48(2,5,7) + oWELLSL48(2,6,7)

! DISTRIBUTION OF PRODUCTION BY TYPE AND REGION, ESTIMATED BASED ON AEO2014 REFERENCE CASE MODEL IN 2020 U_PROD_CONV(1) = 0.0000 U_PROD_CONV(2) = 0.0455 U_PROD_CONV(3) = 0.0085 U_PROD_CONV(4) = 0.0702 U_PROD_CONV(5) = 0.0041 U_PROD_CONV(6) = 0.0000 U_PROD_CONV(7) = 0.0040 U_PROD_CONV(8) = 0.0446 U_PROD_CONV(9) = 0.3448 U_PROD_CONV(10) = 0.2801 U_PROD_CONV(11) = 0.0372 U_PROD_CONV(12) = 0.0776 U_PROD_CONV(13) = 0.0000 U_PROD_CONV(14) = 0.0000 U_PROD_CONV(15) = 0.0234 U_PROD_CONV(16) = 0.0463 U_PROD_CONV(17) = 0.0136 U_PROD_TIGHT(1) = 0.0000U_PROD_TIGHT(2) = 0.0008 U_PROD_TIGHT(3) = 0.0055 U_PROD_TIGHT(4) = 0.0002 U_PROD_TIGHT(5) = 0.0025 U_PROD_TIGHT(6) = 0.0000 U_PROD_TIGHT(7) = 0.0043 U_PROD_TIGHT(8) = 0.0006 U_PROD_TIGHT(9) = 0.2017 U_PROD_TIGHT(10) = 0.1040 U_PROD_TIGHT(11) = 0.1209 U_PROD_TIGHT(12) = 0.4183 U_PROD_TIGHT(13) = 0.0000 U_PROD_TIGHT(14) = 0.0000 U_PROD_TIGHT(15) = 0.0163 U_PROD_TIGHT(16) = 0.1248 U_PROD_TIGHT(17) = 0.0000 U_PROD_SHALE(1) = 0.0000 U_PROD_SHALE(2) = 0.3385 U_PROD_SHALE(3) = 0.0077 U_PROD_SHALE(4) = 0.0000 U_PROD_SHALE(5) = 0.0000 U_PROD_SHALE(6) = 0.0246 U_PROD_SHALE(7) = 0.0011 U_PROD_SHALE(8) = 0.0000 U_PROD_SHALE(9) = 0.3616 U_PROD_SHALE(10) = 0.1470 U_PROD_SHALE(11) = 0.1163 U_PROD_SHALE(12) = 0.0031 U_PROD_SHALE(13) = 0.0000 U_PROD_SHALE(14) = 0.0000 U_PROD_SHALE(15) = 0.0001 U_PROD_SHALE(16) = 0.0000 U_PROD_SHALE(17) = 0.0000 U_PROD_CBM(1) = 0.0000 U_PROD_CBM(2) = 0.0000 U_PROD_CBM(3) = 0.0000 U_PROD_CBM(4) = 0.0004 U_PROD_CBM(5) = 0.0002 U_PROD_CBM(6) = 0.0181 U_PROD_CBM(7) = 0.0000 U_PROD_CBM(8) = 0.0494 U_PROD_CBM(9) = 0.0081 U_PROD_CBM(10) = 0.0242 U_PROD_CBM(11) = 0.0151 U_PROD_CBM(12) = 0.8543 U_PROD_CBM(13) = 0.0000 U_PROD_CBM(14) = 0.0000 U_PROD_CBM(15) = 0.0144 U_PROD_CBM(16) = 0.0160 U_PROD_CBM(17) = 0.0000

! ESTIMATES AND DISTRIBUTES ESTIMATES OF CAPTURED GAS (IN BCF) ACROSS WELL TYPES AND REGION NG_REDUCT_NEW = (0.000019 * OIL_WELLS_TOT * U_PROD_SHALE(IREG) & + 0.000136 * CONV_WELLS_TOT * U_PROD_CONV(IREG) & + 0.000136 * TIGHT_WELLS_TOT * U_PROD_TIGHT(IREG) & + 0.000136 * SHALE_WELLS_TOT * U_PROD_SHALE(IREG) & + 0.000136 * CBM_WELLS_TOT * U_PROD_CBM(IREG)

! ADDS NATURAL GAS RECOVERED BE NEW SOURCES

XQBASE = NG_REDUCT_NEW + XQBASE

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

XPBASE = ZWPRLAG(IREG) ELSEIF (SUPCRV.EQ.10) THEN ICNT = 0 XPBASE = 0.0 DO J=1,IROLL IF (ZWPROLL(IREG,J).GT.0.001) THEN ICNT = ICNT + 1 XPBASE = XPBASE + ZWPROLL(IREG,J) ENDIF ENDDO IF (ICNT.NE.0 .AND. MODYR.GT.LHISYR) THEN XPBASE = XPBASE / REAL(ICNT) ELSE XPBASE = ZWPRLAG(IREG) ENDIF ELSEIF (SUPCRV.EQ.3) THEN XPBASE = REG_CNST(IVREG) + (0.686*ZWPRLAG(IREG)) + (0.024*oIT_WOP(CURIYR,1)) - ZOGTAXPREM(IREG) ELSEIF (SUPCRV.EQ.4) THEN XPBASE = exp(-24.2580) * UGRRESSHR**1.62970 * oEXSPEND(1,curiyr-1)**0.066852 * HDD**2.22467 & * ZWPRLAG(IREG)**0.527302 * exp(-24.2580*(-0.527302)) * UGRRESSHRLAG**(-0.527302*1.62970) &

* oEXSPEND(1,curiyr-2)**(-0.527302*0.066852) * HDD**(-0.527302*2.22467) ELSEIF (SUPCRV.EQ.5) THEN XPBASE = exp(-16.4735) * UGRRESSHR**1.16172 * oEXSPEND(1,curiyr-1)**0.072937 * HDD**1.49735 & * ZWPRLAG(IREG)**0.317304 * exp(-16.4735*(-0.317304)) * UGRRESSHRLAG**(-0.317304*1.16172) &

* oEXSPEND(1,curiyr-2)**(-0.317304*0.072937) * HDD**(-0.317304*1.49735) ELSEIF (SUPCRV.EQ.6) THEN ! AEO2010 if (zogresng(ireg).gt.0.) THEN A1 = -10.6700 ! constant B4 = -0.014253 ! BOY res B1 = 0.633804 ! ugrresshr B2 = 0.190494 ! average drill cost B3 = 0.882912 ! HDD B5 = 0.279016 ! WOP RHO = 0.398350 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 & * ZOGRESNG(IREG)**(B4) & * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) & * (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) & * ZOGRESNGLAG1(IREG)**(-RHO*B4) & * oIT_WOP(CURIYR-1,1)**(-RHO*B5) & * 1.00000 ELSE XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG)) ENDIF ELSEIF (SUPCRV.EQ.7) THEN if (zogresng(ireg).gt.0.) THEN A1 = -0.298040 ! constant B4 = 0. ! BOY res B1 = 0. ! ugrresshr B2 = 0.403666 ! average cost per mcf B3 = 0. ! HDD B5 = 0.311518 ! WOP RHO = 0.504134 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 & * ZOGRESNG(IREG)**(B4) & * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) & * (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &* ZOGRESNGLAG1(IREG)**(-RHO*B4) & * oIT_WOP(CURIYR-1,1)**(-RHO*B5) & * 1.01076 ELSE XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG)) ENDIF ELSEIF (SUPCRV.EQ.8) THEN if (zogresng(ireg).gt.0.) THEN A1 = -1.46449 ! constant B4 = 0. ! BOY res B1 = 0. ! ugrresshr B2 = 0.121770 ! average drill cost per reserve additions B3 = 0. ! HDD B5 = 0.544238 ! WOP RHO = 0.626528 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 & * ZOGRESNG(IREG)**(B4) & * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) & * (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) & * ZOGRESNGLAG1(IREG)**(-RHO*B4) & * oIT_WOP(CURIYR-1,1)**(-RHO*B5) & * 1.00303 ELSE XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG)) ENDIF ELSEIF (SUPCRV.EQ.9) THEN if (zogresng(ireg).gt.0.) THEN A1 = 0.547003 ! constant B4 = 0. ! BOY res B1 = 0. ! ugrresshr B2 = 0.637656 ! average cost per mcf B3 = 0. ! HDD B5 = 0. ! WOP RHO = 0.379721 XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 & * ZOGRESNG(IREG)**(B4) & * oIT_WOP(CURIYR,1)**B5 * ZWPRLAG(IREG)**RHO & * exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) & * (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) & * ZOGRESNGLAG1(IREG)**(-RHO*B4) & * oIT_WOP(CURIYR-1,1)**(-RHO*B5) & * 1.02188 ELSE XPBASE = (ZWPRLAG(IREG) - ZOGTAXPREM(IREG)) ENDIF ELSEIF (SUPCRV.EQ.21) THEN IF (MODYR.LE.2006) THEN ! steo? IF (SUPTYPE(IREG).LE.9) THEN XPBASE = 0.95*ZWPRLAG(IREG) - ZOGTAXPREM(IREG) - 0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))

ELSE XPBASE = 0.66 + (0.75*ZWPRLAG(IREG)) - ZOGTAXPREM(IREG) ENDIF ELSE XPBASE = ZWPRLAG(IREG) - ZOGTAXPREM(IREG) - 0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))

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

ELSEIF (SUPCRV.EQ.8) THEN XPBASE = exp(-2.88475) * UGRRESSHR**0.749417 * oIT_WOP(CURIYR,1)**0.325610 &

* ZWPRLAG(IREG)**0.339752 * exp(-2.88475*(-0.339752)) * UGRRESSHRLAG**(-0.339752*0.749417) &

* oIT_WOP(CURIYR-1,1)**(-0.339752*0.325610) ELSEIF (SUPCRV.EQ.9) THEN! IF (ZOGRESNG(IREG).GT.0.0) THEN ! XPBASE = ZOGRESNG(IREG)**-0.047340 * oIT_WOP(CURIYR,1)**0.136745 *(UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432 & ! * ZWPRLAG(IREG)**0.277866 * ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340) & ! * oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745) * (UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432) ! ! Z1 = ZOGRESNG(IREG)**-0.047340 ! Z2 = oIT_WOP(CURIYR,1)**0.136745 ! Z3 = (UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432 ! Z4 = ZWPRLAG(IREG)**0.277866 ! Z5 = ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340) ! Z6 = oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745) ! Z7 = (UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432) ! XPBASE = Z1 * Z2 * Z3 * Z4 * Z5 * Z6 * Z7 ! ELSE

XPBASE = ZWPRLAG(IREG) ! ENDIF ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF (SUPCRV.NE.2) THEN !!!!!!! supply curve type 1 !!!!!!

! ALL OTHER NG PRODUCTION

FIXSUP = ZOGCCAPPRD(IREG) * (1.-PERCNT) AQBASE = XQBASE * (1. - PARM_SUPCRV3) BQBASE = XQBASE * (1. + PARM_SUPCRV3) APBASE = XPBASE * (1.- (PARM_SUPCRV3 /PARM_SUPELAS(3))) BPBASE = XPBASE * (1.+ (PARM_SUPCRV3 /PARM_SUPELAS(3)))
IF (PARM_SUPCRV5 .EQ. 0.0) THEN ! set 5-tier = 3-tier PARM_SUPELAS(1) = PARM_SUPELAS(2) PARM_SUPELAS(5) = PARM_SUPELAS(4) ENDIF

CQBASE = AQBASE * (1. - PARM_SUPCRV5) DQBASE = BQBASE * (1. + PARM_SUPCRV5) CPBASE = APBASE * (1.- (PARM_SUPCRV5 /PARM_SUPELAS(2))) DPBASE = BPBASE * (1.+ (PARM_SUPCRV5 /PARM_SUPELAS(4)))

MIN_NA = ZOGRESNG(IREG) * ZOGPRRNG(IREG) * &

(1.-PERCNT) * PARM_MINPR ! w/o L&P

! THREE/FIVE TIER METHOD

IF (INVAL.EQ.'P') THEN IF (VALUE .LE. CPBASE) THEN QBASE = CQBASE PBASE = CPBASE ELAS = PARM_SUPELAS(1) ELSE IF (VALUE .LE. APBASE) THEN QBASE = AQBASE PBASE = APBASE ELAS = PARM_SUPELAS(2) ELSE IF (VALUE .GE. DPBASE) THEN QBASE = DQBASE PBASE = DPBASE ELAS = PARM_SUPELAS(5) ELSE IF (VALUE .GE. BPBASE) THEN QBASE = BQBASE PBASE = BPBASE ELAS = PARM_SUPELAS(4) ELSE QBASE = XQBASE PBASE = XPBASEELAS = PARM_SUPELAS(3)

END IF NGSUP_PR = (1.-PERCNT) * QBASE * & (1.+(ELAS*(VALUE-PBASE)/PBASE)) + QSHFT ! temp code ! * (1.+(ELAS*(VALUE-PBASE)/PBASE))

NGSUP_PR = AMAX1(NGSUP_PR,MIN_NA) ! w/o L&P NGSUP_PR = FIXSUP + NGSUP_PR NGSUP_PR = AMAX1(NGSUP_PR,0.0) END IF

! THREE TIER METHOD FOR QUANTITIES

IF (INVAL.EQ.'Q') THEN IF (XQBASE.GT.0.0) THEN ! QVAR = (VALUE - FIXSUP) / (1.-PERCNT) ! w/ L&P

QVAR = (VALUE - FIXSUP+QSHFT) / (1.-PERCNT) ! temp code (QSHFT) IF (QVAR .LE. CQBASE) THEN QBASE = CQBASE PBASE = CPBASE ELAS = PARM_SUPELAS(1) ELSE IF (QVAR .LE. AQBASE) THEN QBASE = AQBASE PBASE = APBASE ELAS = PARM_SUPELAS(2) ELSE IF (QVAR .GE. DQBASE) THEN QBASE = DQBASE PBASE = DPBASE ELAS = PARM_SUPELAS(5) ELSE IF (QVAR .GE. BQBASE) THEN QBASE = BQBASE PBASE = BPBASE ELAS = PARM_SUPELAS(4) ELSE QBASE = XQBASE PBASE = XPBASE ELAS = PARM_SUPELAS(3) END IF NGSUP_PR = PBASE * (((1./ELAS)*(QVAR-QBASE)/QBASE) + 1.) ELSE NGSUP_PR = XPBASE END IF IF (NGSUP_PR .LE. 0.0) THEN WRITE(NGUNIT,20) CURIYR,CURITR,IREG,NGSUP_PR,VALUE,XQBASE NGSUP_PR = 0.10 ! SET TO VERY LOW PRICE, BUT NOT NEGATIVE ENDIF END IF

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ELSE IF(SUPCRV .EQ. 2) THEN !!!!!!! supply curve type 2 !!!!!! ! NEW METHOD PER KEVIN FORBES AUGUST 2002

! IF (IREG.EQ.21) THEN

IF (SUPTYPE(IREG).GE.10) THEN IF (CURIYR.LE.1) THEN NGSUP_PR = ZWPRLAG(IREG) ELSE ! EM4 TRACK -- keep here

CNC = -3.70634 CNRHO = 0.619602 CNB1 = 0.325236 CNDL = (0.9184/0.7758)*1.2085 ! convert us87$ to cn92$ CNPRLAG = oOGCNQPRD(NG,CURIYR-1) / oOGRESCAN(NG,CURIYR-1) TMPCAN = EXP(CNC*(1.-CNRHO))*(CNPRLAG/(1.-CNPRLAG))**CNRHO & * oOGCNPPRD(NG,CURIYR-1)**(-1.*CNRHO*CNB1) IF (INVAL.EQ.'Q') THEN NGSUP_PR = (( (VALUE/oOGRESCAN(NG,CURIYR)) / &(TMPCAN * (1.- (VALUE/oOGRESCAN(NG,CURIYR)))) )**(1/CNB1))/CNDL

ENDIF IF (INVAL.EQ.'P') THEN NGSUP_PR = oOGRESCAN(NG,CURIYR) &

* (TMPCAN * (VALUE*CNDL)**CNB1) / & (1. + (TMPCAN * (VALUE*CNDL)**CNB1)) ENDIF ENDIF ELSE
! EM4 TRACK -- keep here

BETA1 = -0.297987 BETA2 = -0.349741 BETA3 = 0.150931 IF (ZOGRESNGLAG1(IREG).GT.0.0.AND.ZOGRESNGLAG2(IREG).GT.0.0) THEN TMPUS = exp(REG_CNST2(IREG)) * (ZOGRADNGLAG1(IREG)/ZOGRESNGLAG1(IREG) + 1)**beta1 & * (ZOGRADNGLAG2(IREG)/ZOGRESNGLAG2(IREG) + 1)**beta2

ENDIF

IF (INVAL.EQ.'P') THEN IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN NGSUP_PR = 0.0 ELSE NGSUP_PR = ZOGRESNG(IREG) &

* (TMPUS * VALUE**BETA3) / & (1. + (TMPUS * VALUE**BETA3)) !CCC WRITE(6,*) ' PROD=', NGSUP_PR

ENDIF

!CCC WRITE(6,*) 'PRICE SENT = ',VALUE !CCC WRITE(6,*) 'NGSUP_PR = ',NGSUP_PR,' RPSHIFT ', !CCC * RPSHIFT(IREG) !CCC WRITE(6,*) ' '

ENDIF

IF (INVAL.EQ.'Q') THEN IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN NGSUP_PR = WPRLAG(IREG) ELSE NGSUP_PR = ((VALUE / ZOGRESNG(IREG)) &

/ (TMPUS * (1 - VALUE/ZOGRESNG(IREG))))**(1/beta3)

WRITE(6,*) 'REGION= ',IREG,'YEAR=',CURIYR+1989 WRITE(6,*) 'TMPUS= ',TMPUS,' VALUE=',VALUE,'RES=',ZOGRESNG(IREG) WRITE(6,*) 'PRICE = ',NGSUP_PR WRITE(6,*) ' ' ENDIF

ENDIF ENDIF ! temp: kevsup ENDIF

! TRACE
! IF (IREG .EQ. SNODES) THEN ! canadian supply ! IF (INVAL.EQ.'Q') THEN ! WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS ! WRITE(NGOERR,15) AQBASE, XQBASE, BQBASE, QVAR, VALUE ! WRITE(NGOERR,16) APBASE, XPBASE, BPBASE, NGSUP_PR ! ELSE ! WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS ! WRITE(NGOERR,17) AQBASE, XQBASE, BQBASE, NGSUP_PR ! WRITE(NGOERR,18) APBASE, XPBASE, BPBASE, VALUE! ENDIF ! ENDIF 14 FORMAT(1X,'NGSUP_PR: YR=',I4,' ITR=',I2,' INVAL=',A1, &

' FIXSUP=',F8.3,' PCTLP=',F8.3,' ELAS=',F8.4) 15 FORMAT(1X,'NGSUP_PR: AQ=',F8.1,' XQ=',F8.1,' BQ=',F8.1, &

' QVAR=',F8.1,' VALUE=',F8.1) 16 FORMAT(1X,'NGSUP_PR: AP=',F8.4,' XP=',F8.4,' BP=',F8.4, &

' SUPPR=',F8.4) 17 FORMAT(1X,'NGSUP_PR: AQ=',F8.1,' XQ=',F8.1,' BQ=',F8.1, &

' SUPPR=',F8.1) 18 FORMAT(1X,'NGSUP_PR: AP=',F8.4,' XP=',F8.4,' BP=',F8.4, &

' VALUE=',F8.4)

IF (NGDBGITR(4,5)) THEN WRITE(NGUNIT,10) CURIYR,CURITR,IREG,INVAL,VALUE,NGSUP_PR WRITE(NGUNIT,11) XQBASE,ZOGRESNG(IREG), & ZOGPRRNG(IREG) END IF 10 FORMAT(1X,'NGSUP_PR: YR=',I3,' ITR=',I3,' REG(1-21)=',I4, &

' P OR Q= ',A1,' VALUE=',F15.4,' NGSUP_PR=',F15.4) 11 FORMAT(5X,'XQBASE=',F12.3,' ZOGRESNG=',F12.3,' ZOGPRRNG=', & F12.3)

20 FORMAT(1X,'ATTN5 NGTDM, NGSUP_PRSUP_PR',I3,' ITR=',I3, & ' IREG(1-21)=',I4,' NGSUP_PR=',F10.3,' VALUE=',F10.1, & ' XQBASE=',F10.1)

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! USE FIXED AND VAR TARIFF INFO TO CALC ARC FEE ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! FUNCTIONS USED: NGPIPE_VARTAR ! NGSTR_VARTAR ! ! NOTES: MAY WANT TO ADD PR ADJUSTMENT FOR PIPE FUEL ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_ARCFEE IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc'

INTEGER*4 L,A ! COUNTERS INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 STID ! STORAGE NODE ID (1-14) INTEGER*4 XNET ! END-USE(1,3) VS SHR(1,2) NETWORK INDICATOR

REAL*4 NGSTR_VARTAR ! FUNCTION (from ptm) REAL*4 NGPIPE_VARTAR ! FUNCTION (from ptm) REAL*4 X1NGSTR_VARTAR ! FUNCTION (new) REAL*4 XNGSTR_VARTAR !*FUNCTION (temp) REAL*4 XNGPIPE_VARTAR !*FUNCTION (temp)REAL*4 Q ! FLOW ALONG ARC W/IN PK OR OP SEASON ! -------------

! TARIFF ON ALL PRIMARY ARCS

DO NET=1,NETWORK DO A=1,NARCS SRC = ARC_2NODE(A,1) DEST= ARC_2NODE(A,2) Q = FLOW(NET,A) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & NGPIPE_VARTAR(NET,A,Q) ! FUNCTION IF (NET .EQ. PKNET) THEN ! from ngptmX.f !! ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & !! NGPIPE_VARTAR(NET,A,Q) ! FUNCTION

ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) ELSE ! from ngptmX.f !! ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & ! from ngptmX.f !! NGPIPE_VARTAR(NET,A,Q)

ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) ! from ngptmX.f ENDIF ELSE IF (SRC .GT. (TNODES+SNODES)) THEN ! STR ARCS IF (NET .EQ. PKNET) THEN STID = SRC - (TNODES+SNODES) ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & X1NGSTR_VARTAR(STID,Q) ! FUNCTION ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + & X1NGSTR_VARTAR(STID,Q) ! FUNCTION ELSE ARC_ENDFEE(NET,A) = 0.0 ARC_SHRFEE(NET,A) = 0.0 ENDIF ELSE ! SUPPLY ARCS ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) ENDIF ENDDO ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! PLACEHOLDER FOR PIPELINE VARIABLE TARIFF FUNCTION ! ! STATUS: UNDER CONSTRUCTION -- CHETHA WILL PROVIDE THIS ROUTINE ! ! CALLED BY: NGSET_ARCFEE ! ! NOTES: NEED TO TRANSLATE CAPACITY INTO PK (1/3) OR OP (2/3) ! AND USE PKUTZ & OPUTZ TO GET PR FOR EFFECTIVE FLOW ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION XNGPIPE_VARTAR(XNET,A,SRC,DEST,Q) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc'

INTEGER*4 A ! ARC ID INTEGER*4 SRC, DEST ! SOURCE, DEST NODES ON ARC INTEGER*4 XNET ! NETWORK SIGNAL

! mapping of network signal for var tar along pipe:! 1 = pk for use w/ sharing price calc ! 2 = op for use w/ sharing price calc ! 1 = pk for use w/ end-use price calc ! 3 = op for use w/ end-use price calc

REAL*4 Q ! QUANTITY FLOWING ON NETWORK ARC REAL*4 QA ! EQUIVALENT ANNUAL FLOW ! -------------

IF (XNET .EQ. 1) THEN QA = Q / PKSHR_YR ELSE QA = Q / (1.-PKSHR_YR) ENDIF

! EM4 TRACK -- routine not called IF ((SRC.EQ.2) .AND. (DEST.EQ.1)) THEN XNGPIPE_VARTAR = (.023/413.)*QA ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.2)) THEN XNGPIPE_VARTAR = (.089/780.)*QA ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.5)) THEN XNGPIPE_VARTAR = (.133/890.)*QA ELSE IF ((SRC.EQ.4) .AND. (DEST.EQ.3)) THEN XNGPIPE_VARTAR = (.099/3106.)*QA ELSE IF ((SRC.EQ.5) .AND. (DEST.EQ.2)) THEN XNGPIPE_VARTAR = (.106/2496.)*QA ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.3)) THEN XNGPIPE_VARTAR = (.100/3525.)*QA ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.5)) THEN XNGPIPE_VARTAR = (.125/2664.)*QA ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.10)) THEN XNGPIPE_VARTAR = (.081/ 378.)*QA ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.4)) THEN XNGPIPE_VARTAR = (.145/2966.)*QA ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.6)) THEN XNGPIPE_VARTAR = (.108/7207.)*QA ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.4)) THEN XNGPIPE_VARTAR = (.074/ 950.)*QA ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.7)) THEN XNGPIPE_VARTAR = (.080/ 73.)*QA ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.9)) THEN XNGPIPE_VARTAR = (.020/ 621.)*QA ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.11)) THEN XNGPIPE_VARTAR = (.049/ 213.)*QA ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.12)) THEN XNGPIPE_VARTAR = (.063/1353.)*QA ELSE IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN XNGPIPE_VARTAR = (.023/ 413.)*QA ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.7)) THEN XNGPIPE_VARTAR = (.035/1110.)*QA ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.12)) THEN XNGPIPE_VARTAR = (.063/1353.)*QA ! ELSE IF ((SRC.EQ.13) .AND. (DEST.EQ.1)) THEN ! XNGPIPE_VARTAR = (.007/ 24.)*QA ! ELSE IF ((SRC.EQ.14) .AND. (DEST.EQ.2)) THEN ! XNGPIPE_VARTAR = (.007/ 150.)*QA ! ELSE IF ((SRC.EQ.16) .AND. (DEST.EQ.4)) THEN ! XNGPIPE_VARTAR = (.047/ 789.)*QA ! ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.4)) THEN ! XNGPIPE_VARTAR = (.059/ 993.)*QA ! ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.8)) THEN ! XNGPIPE_VARTAR = (.059/ 993.)*QA ! ELSE IF ((SRC.EQ.18) .AND. (DEST.EQ.9)) THEN ! XNGPIPE_VARTAR = (.310/ 301.)*QA ! ELSE IF ((SRC.EQ.19) .AND. (DEST.EQ.9)) THEN ! XNGPIPE_VARTAR = (.310/ 301.)*QA! ELSE IF ((SRC.EQ.20) .AND. (DEST.EQ.7)) THEN ! XNGPIPE_VARTAR = (.142/ 16.)*QA ! ELSE IF ((SRC.EQ.21) .AND. (DEST.EQ.11)) THEN ! XNGPIPE_VARTAR = (.142/ 1.)*QA ! ELSE IF ((SRC.EQ.22) .AND. (DEST.EQ.12)) THEN ! XNGPIPE_VARTAR = (0.)*QA

! IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN ! IF (Q .LE. 413.) THEN ! XNGPIPE_VARTAR = .0000557*Q ! ELSEIF (Q .LE. 433.) THEN ! XNGPIPE_VARTAR = .0003*Q ! ELSEIF (Q .LE. 825.) THEN ! XNGPIPE_VARTAR = .0004796*Q ! ELSEIF (Q .LE. 1238.) THEN ! XNGPIPE_VARTAR = .00103*Q ! ELSE ! XNGPIPE_VARTAR = .00189*Q ! ENDIF

ELSE XNGPIPE_VARTAR = .001 ENDIF
! XNGPIPE_VARTAR = .001 ! temp code

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! PLACEHOLDER FOR STORAGE VARIABLE TARIFF FUNCTION ! ! STATUS: UNDER CONSTRUCTION -- CHETHA WILL PROVIDE THIS ROUTINE ! ! CALLED BY: NGSET_ARCFEE ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION XNGSTR_VARTAR(S,Q) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc'

INTEGER*4 S ! STORAGE ID (1-14)

REAL*4 Q ! QUANTITY FLOWING ON NETWORK ARC ! -------------

XNGSTR_VARTAR = .001

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! MOVEMENT UP NETWORKS TO SET ARC AND NODE PRICES ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! QUESTIONS: HOW DO WE ADJUST PR FOR IMPACT FROM BKSTOP? ! --PERCENTAGE INCREASE IN NODE_SHRPR & NODE_ENDPR ?? !! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! SUBROUTINE NGUP_TREE(NET) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 L,A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC !CCC INTEGER*4 SHR_PRFLG ! FLAG INDICATING SHR_PR HAS BEEN INIT INTEGER*4 I,J,K,N ! GENERIC INDICES
REAL*4 SHR_PR ! MARGINAL PR AT NODE ($/MCF) REAL*4 PQ, Q ! HOLDS TOT USED TO CALC AVG PR REAL*4 ARCPQ,ARCQ ! HOLDS TOT USED TO ADJ PR FOR PFUEL LOSS REAL*4 TARCPQ,TARCQ ! HOLDS TOT USED TO AVG PR REAL*4 HBSPOT(NETWORK,DNODES,FSPOTYR:LHISYR) ! BENCHMARK FACTOR FOR REGIONAL SPOT PRICES HISTORICAL REAL*4 BSPOT(NETWORK,DNODES) ! BENCHMARK FACTOR FOR REGIONAL SPOT PRICES FORECAST

LOGICAL FIRST ! FIRST TIME CALLED IN FIRST FORECAST YEAR DATA FIRST/.TRUE./

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

DO L=NPROC,1,-1 ! MOVE UP TREE DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

SHR_PR = 0.0 !CCC SHR_PRFLG = 0

PQ = 0.0 Q = 0.0 TARCPQ = 0.0 TARCQ = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) ! BEFORE PIPEFUEL LOSS ADJ

ARC_ENDPR(NET,A) = NODE_ENDPR(NET,SRC) + ARC_ENDFEE(NET,A) ARCPQ = ARC_ENDPR(NET,A) * FLOW(NET,A) ARCQ = FLOW(NET,A) - ARC_PFUEL(NET,A) ! AFTER PIPEFUEL LOSS ADJ

IF (ARCQ .GT. 0.) THEN ARC_ENDPR(NET,A) = ARCPQ / ARCQ ! AFTER PFUEL LOSS ADJ ENDIF PQ = PQ + ARCPQ Q = Q + ARCQ

! BEFORE PIPEFUEL LOSS ADJ

ARC_SHRPR(NET,A) = NODE_SHRPR(NET,SRC) + ARC_SHRFEE(NET,A) ARCPQ = ARC_SHRPR(NET,A) * FLOW(NET,A) ARCQ = FLOW(NET,A) - ARC_PFUEL(NET,A) ! AFTER PIPEFUEL LOSS ADJ

IF (ARCQ .GT. 0.) THEN ARC_SHRPR(NET,A) = ARCPQ / ARCQ ! AFTER PFUEL LOSS ADJ ENDIF! THE FOLLOWING REPLACES THE SUCCEEDING LINES OF CODE ! IF (FLOW_REM(NET,A) .GT. 0.0) THEN

TARCPQ = TARCPQ + ARCPQ TARCQ = TARCQ + ARCQ ! ENDIF !CCC IF (FLOW_REM(NET,A) .GT. 0.0) THEN !CCC IF (SHR_PRFLG .EQ. 0) THEN !CCC SHR_PR = ARC_SHRPR(NET,A) !CCC SHR_PRFLG = 1 !CCC ELSE !CCC SHR_PR = AMIN1(SHR_PR, ARC_SHRPR(NET,A)) !CCC ENDIF !CCC ENDIF

ENDDO

! THE FOLLOWING 5 LINES ADDED W/ ABOVE ADDITION IF (TARCQ .GT. 0.0) THEN SHR_PR = TARCPQ / TARCQ ELSE SHR_PR = ARC_SHRPR(NET,ARC_1) ! CYCLE=1 DO A=ARC_1,ARC_2 SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A)) ENDDO ENDIF

!CCC IF (SHR_PRFLG .EQ. 0) THEN ! EXPANSION ON ALL ARCS !CCC SHR_PR = ARC_SHRPR(NET,ARC_1) !CCC DO A=ARC_1,ARC_2 !CCC SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A)) !CCC ENDDO !CCC ENDIF

NODE_SHRPR(NET,DEST) = SHR_PR IF (Q .GT. 0.0) THEN NODE_ENDPR(NET,DEST) = PQ / Q ELSE NODE_ENDPR(NET,DEST) = SHR_PR ENDIF

! ADJUST NODE PRICE FOR PR IMPACT FROM INTRAREG PFUEL

IF (INTRA_PFUEL(NET,DEST).GT.0.0) THEN IF ((NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST)) .GT. 0.0) THEN NODE_SHRPR(NET,DEST)=(NODE_SHRPR(NET,DEST)*NODE_DMD(NET,DEST)) / & (NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST)) NODE_ENDPR(NET,DEST)=(NODE_ENDPR(NET,DEST)*NODE_DMD(NET,DEST)) / & (NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST)) ELSE write(6,'(A,I2,A,I2)') " Preventing infinity caused by NODE_DMD = INTRA_PFUEL at NET=",NET," DEST=",DEST

ENDIF ENDIF

! BKSTOP PRICE PENALTY IF (BKSTOP(NET,DEST) .GT. 0.) THEN IF (RBKSTOP_FLG(NET,DEST) .EQ. 0) THEN BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5 ENDIF RBKSTOP_PADJ(NET,DEST) = RBKSTOP_PADJ(NET,DEST) + & BKSTOP_PADJ(NET,DEST) RBKSTOP_FLG(NET,DEST) = 1 ELSE ! IF (RBKSTOP_FLG(NET,DEST) .EQ. 1) THEN ! BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5 ! ENDIF ! RBKSTOP_PADJ(NET,DEST) = AMAX1(0.0,! * (RBKSTOP_PADJ(NET,DEST) - BKSTOP_PADJ(NET,DEST)))

RBKSTOP_FLG(NET,DEST) = 0 ENDIF
! RBKSTOP_PADJ(NET,DEST) = 0.0 ! temp code

NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + & RBKSTOP_PADJ(NET,DEST) ! NODE_ENDPR(NET,DEST) = NODE_ENDPR(NET,DEST) + ! + RBKSTOP_PADJ(NET,DEST)

! BENCHMARK TO HISTORICAL SPOT PRICES

IF (DEST.LE.DNODES .AND. MODYR.GE.FSPOTYR) THEN IF (MODYR.LE.LHISYR) THEN HBSPOT(NET,DEST,MODYR) = HNSPOT(NET,DEST,MODYR) - NODE_SHRPR(NET,DEST) NODE_SHRPR(NET,DEST) = HNSPOT(NET,DEST,MODYR) ELSE IF (FIRST) THEN BSPOT = 0.0 DO N=1,NETWORK DO J=1,DNODES DO K=FSPOTYR,LHISYR BSPOT(N,J) = BSPOT(N,J) + HBSPOT(N,J,K) ENDDO BSPOT(N,J) = BSPOT(N,J) / REAL(LHISYR-FSPOTYR+1) ENDDO ENDDO FIRST = .FALSE. ENDIF NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + BSPOT(NET,DEST) ENDIF ENDIF ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET STORAGE PRICES FOR USE IN PK, BASED ON OP RESULTS ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_STORPR IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc'

INTEGER*4 L,A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC

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

DO L=1,NPROC ! LOOP OVER TRANSFER NODES DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2)DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1) IF (SRC .GT. (TNODES+SNODES)) THEN NODE_SHRPR(PKNET,SRC) = NODE_SHRPR(OPNET,DEST) NODE_ENDPR(PKNET,SRC) = NODE_ENDPR(OPNET,DEST) ENDIF ENDDO ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET INTRAREGIONAL FLOWS, CAPACITIES, AND TARIFFS ! ! STATUS: ! ! CALLED BY: NGTDM_ITM ! ! QUESTIONS: ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_INTRAFLO IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'ngptmitm'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A ! COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

REAL*4 FAC(DNODES) ! SEASONAL SHARE FACTOR REAL*4 PKNETDMD ! PK NET NODE DMD (W/O PIPEFUEL) REAL*4 OPNETDMD ! OP NET NODE DMD (W/O PIPEFUEL) REAL*4 NGPIPE_VARTAR ! PTM FUNCTION TO SET PIPE TARIFF REAL*4 TEMP ! TEMP HOLD INTRAREG VARTAR ! --------

! DEFINE INTRAREGIONAL FLOWS, FLOW FACTOR, AND TARIFFS ! FLO_FAC = INTRA_FLO / NODE_DMD(W/O PF)

DO DEST=1,DNODES DO NET=1,NETWORK IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN IF (NET .EQ. PKNET) THEN ! PEAK SEASON PKNETDMD = NODE_DMD(PKNET,DEST)-PFUEL(PKNET,DEST) OPNETDMD = NODE_DMD(OPNET,DEST)-PFUEL(OPNET,DEST) FAC(DEST) = PKNETDMD / (PKNETDMD + OPNETDMD) ELSE ! OFFPEAK SEASON FAC(DEST) = 1. - FAC(DEST) ENDIF A = SNODE_2ARC(DEST,DEST) INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR) HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / & (NODE_DMD(NET,DEST) - PFUEL(NET,DEST)) ! write(69,*)'intra',modyr,dest,net,INTRA_FLO(NET,DEST,MODYR),SAFLOW(A,MODYR),NODE_DMD(NET,D EST),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 = INTRAREG_TAR(NET,DEST) - INTRAREG_FIXTAR(NET,DEST) !CCC WRITE(4,1000) MODYR,NET,DEST,INTRAREG_FIXTAR(NET,DEST), !CCC * TEMP,INTRAREG_TAR(NET,DEST),INTRA_FLO(NET,DEST,MODYR) !1000 FORMAT(' INTRA ',I4,2I3,3F6.3,F10.2)

ENDDO ENDDO

IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN CALL HNGSET_CGPR ELSE DO DEST=1,DNODES DO NET=1,NETWORK INTRAREG_TAR(NET,DEST) = INTRAREG_FIXTAR(NET,DEST) + & NGPIPE_VARTAR(NET,NARCS+DEST,INTRA_FLO(NET,DEST,MODYR)) ! PTM function ENDDO ENDDO ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET END-USE SECTOR PRICES BASED ON AVERAGE NODE PRICES ! AND HUB MARKUPS (PROVIDED BY DTM) ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! QUESTIONS: WHAT ABOUT LOSSES ALONG DISTRIBUTOR ARCS? ! DO NEW QUANTITIES NEED TO BE DEFINED HERE? ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_SECPR IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngdtminc' include 'ngcdmdinc' include 'ngptmitm' include 'ngsteoinc' include 'ogglobal'

INTEGER*4 N ! DEMAND NODES INTEGER*4 CENREG ! CENSUS DIVISION INTEGER*4 J ! COUNTER INTEGER*4 NET ! REPRESENTS PK/OP NETWORKS INTEGER*4 SEC ! SECTOR ID

REAL*4 PQ ! TOTAL (NODE PR * DMD QTY)REAL*4 Q ! TOTAL DMD QTY

REAL*4 PQ_F(DNODES) ! PR * QTY FOR FIRM UTIL REAL*4 PQ_I(DNODES) ! PR * QTY FOR INTRP UTIL REAL*4 Q_F(DNODES) ! QTY FOR FIRM UTIL REAL*4 Q_I(DNODES) ! QTY FOR INTRP UTIL REAL*4 NGSET_INTRATAR! FUNCTION TO SET INTRAREG TARIFFS

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

! SET SEASONAL F/I END-USE PRICES FOR NONUTILITY SECTORS

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES DO NET=1,NETWORK ! LOOP OVER PK/OP NETWORKS

CGPR(NET,N) = NODE_ENDPR(NET,N) + INTRAREG_TAR(NET,N) + &

INTRAST_TAR(N) + CGBENCH(NET,N) DO SEC=1,DSEC-1 ! NONUTILITY (F TRANS WILL BE REPLACED) ! NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N) + ! * SCALE_FPR(MODYR) ! NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N) + ! * SCALE_IPR(MODYR)

NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N) NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N) ENDDO ! FLEET AND PERSONAL VEHICLES SEC=4 ! NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N) + ! * SCALE_FPR(MODYR) ! NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N) + ! * SCALE_FPR(MODYR)

NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N) NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N) IF (OPTELS.EQ.0) THEN NGPR_TRFV_SL(NET,N) = CGPR(NET,N) + DTAR_TRFV_SL(NET,N) NGPR_TRPV_SL(NET,N) = CGPR(NET,N) + DTAR_TRPV_SL(NET,N) ELSE NGPR_TRFV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRFV_SL(NET,N) NGPR_TRPV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRPV_SL(NET,N) ENDIF
! assume ship prices same as for vehicles except no state taxes ! assume rail prices same as for vehicles except no taxes and discount on LNG

NGPR_TRLN_SR(NET,N) = NGPR_TRFV_SL(NET,N) - TRAIN_DISC - ((STAXL(N)+FTAXL) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_TRCN_SR(NET,N) = NGPR_TRFV_SF(NET,N) - ((STAX(N)+FTAX) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_TRLN_SS(NET,N) = NGPR_TRFV_SL(NET,N) - (STAXL(N) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_TRCN_SS(NET,N) = NGPR_TRFV_SF(NET,N) - (STAX(N) / (oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_SF(NET,SEC,N) = & ( (NGPR_TRFV_SF(NET,N) * BASQ_TRFV_SF(NET,N)) + & (NGPR_TRPV_SF(NET,N) * BASQ_TRPV_SF(NET,N)) + & (NGPR_TRFV_SL(NET,N) * BASQ_TRFV_SL(NET,N)) + & (NGPR_TRPV_SL(NET,N) * BASQ_TRPV_SL(NET,N)) + & (NGPR_TRLN_SR(NET,N) * BASQ_TRLN_SR(NET,N)) + & (NGPR_TRCN_SR(NET,N) * BASQ_TRCN_SR(NET,N)) + & (NGPR_TRLN_SS(NET,N) * BASQ_TRLN_SS(NET,N)) + & (NGPR_TRCN_SS(NET,N) * BASQ_TRCN_SS(NET,N)) ) / & (BASQ_TRFV_SF(NET,N) + BASQ_TRPV_SF(NET,N) + & BASQ_TRFV_SL(NET,N) + BASQ_TRPV_SL(NET,N) + & BASQ_TRLN_SR(NET,N) + BASQ_TRCN_SR(NET,N) + & BASQ_TRLN_SS(NET,N) + BASQ_TRCN_SS(NET,N)) ENDDOENDDO

! SET SEASONAL F/I END-USE PRICES FOR NONUTILITY SECTORS

DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16 N = EMMSUB_NG(J) ! NGTDM REGION 1-12 DO NET=1,NETWORK ! NGUPR_SF(NET,J) = CGPR(NET,N) + UDTAR_SF(NET,J) + ! * SCALE_FPR(MODYR) ! NGUPR_SI(NET,J) = CGPR(NET,N) + UDTAR_SI(NET,J) + ! * SCALE_IPR(MODYR)

IF (OPTELS.EQ.0) THEN NGUPR_SF(NET,J) = CGPR(NET,N) + UDTAR_SF(NET,J) NGUPR_SI(NET,J) = CGPR(NET,N) + UDTAR_SI(NET,J) ELSE NGUPR_SF(NET,J) = NODE_SHRPR(NET,N) + UDTAR_SF(NET,J) NGUPR_SI(NET,J) = NODE_SHRPR(NET,N) + UDTAR_SI(NET,J) ENDIF
! temp set f * i to average

IF ((BASUQTY_SF(NET,J)+BASUQTY_SI(NET,J)) .GT. 0.0000001) THEN NGUPR_SF(NET,J) = ((NGUPR_SF(NET,J)*BASUQTY_SF(NET,J)) + & (NGUPR_SI(NET,J)*BASUQTY_SI(NET,J))) / & (BASUQTY_SF(NET,J) + BASUQTY_SI(NET,J)) ELSE NGUPR_SF(NET,J) = 2.0 ENDIF NGUPR_SI(NET,J) = NGUPR_SF(NET,J) ENDDO ENDDO

! SET STEO SCALE FACTOR AND ADJUST END-USE PRICES

IF (MODYR .GT. EHISYR) THEN CALL NGSTEO_BENCHENDPR

DO NET=1,NETWORK DO N=1,DNODES DO SEC=1,DSEC-1 NGPR_SF(NET,SEC,N) = NGPR_SF(NET,SEC,N) + SCALE_FPR(SEC,MODYR) NGPR_SI(NET,SEC,N) = NGPR_SI(NET,SEC,N) + SCALE_IPR(SEC,MODYR) ENDDO

SEC=4 ! TRANS NGPR_TRFV_SF(NET,N) = NGPR_TRFV_SF(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRPV_SF(NET,N) = NGPR_TRPV_SF(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRFV_SL(NET,N) = NGPR_TRFV_SL(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRPV_SL(NET,N) = NGPR_TRPV_SL(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRLN_SR(NET,N) = NGPR_TRLN_SR(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRCN_SR(NET,N) = NGPR_TRCN_SR(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRLN_SS(NET,N) = NGPR_TRLN_SS(NET,N) + SCALE_FPR(SEC,MODYR) NGPR_TRCN_SS(NET,N) = NGPR_TRCN_SS(NET,N) + SCALE_FPR(SEC,MODYR) ENDDO

SEC = 5 ! UTILITY DO J=1,NNGEM-1 NGUPR_SF(NET,J) = NGUPR_SF(NET,J) + SCALE_FPR(SEC,MODYR) NGUPR_SI(NET,J) = NGUPR_SI(NET,J) + SCALE_IPR(SEC,MODYR) ENDDO ENDDO ENDIF

! SET ANNUAL F/I END-USE PRICES FOR NONUTILITY SECTORS

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES DO SEC=1,DSEC-1 ! NONUTILITY (F TRANS WILL BE REPLACED)NGPR_F(SEC,N) = PKSHR_DMD(SEC,N) * NGPR_SF(PKNET,SEC,N) + & (1.-PKSHR_DMD(SEC,N))* NGPR_SF(OPNET,SEC,N)

NGPR_I(SEC,N) = PKSHR_DMD(SEC,N) * NGPR_SI(PKNET,SEC,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_SI(OPNET,SEC,N) ENDDO

SEC=4 ! FLEET AND PERSONAL VEHICLES NGPR_TRFV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SF(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRFV_SF(OPNET,N) NGPR_TRPV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SF(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRPV_SF(OPNET,N) NGPR_TRFV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SL(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRFV_SL(OPNET,N) NGPR_TRPV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SL(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRPV_SL(OPNET,N) NGPR_TRLN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SR(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRLN_SR(OPNET,N) NGPR_TRCN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SR(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRCN_SR(OPNET,N) NGPR_TRLN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SS(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRLN_SS(OPNET,N) NGPR_TRCN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SS(PKNET,N) + &

(1.-PKSHR_DMD(SEC,N))* NGPR_TRCN_SS(OPNET,N)

! COMPARE CNG PRICE FOR PERSONNEL VEHICLES TO COMMERCIAL MOTOR GASOLINE PRICE

CENREG = NG_CENMAP(N) ! CENSUS DIVISION ! NGPR_TRPV_F(N) = AMAX1(NGPR_TRPV_F(N)+(oJNGTR(CURIYR)*oCFNGN(CURIYR)), & ! ((oPMGTR(CENREG,CURIYR)+oJMGTR(CURIYR))*oCFNGN(CURIYR))**PERMG) - & ! oJNGTR(CURIYR)*oCFNGN(CURIYR) SEC=4 ! REPLACE F TRANS NGPR_F(SEC,N) = ( (NGPR_TRFV_F(N) * BASQ_TRFV_F(N)) + & (NGPR_TRPV_F(N) * BASQ_TRPV_F(N)) + & (NGPR_TRFV_L(N) * BASQ_TRFV_L(N)) + & (NGPR_TRPV_L(N) * BASQ_TRPV_L(N)) + & (NGPR_TRLN_R(N) * BASQ_TRLN_R(N)) + & (NGPR_TRCN_R(N) * BASQ_TRCN_R(N)) + & (NGPR_TRLN_S(N) * BASQ_TRLN_S(N)) + & (NGPR_TRCN_S(N) * BASQ_TRCN_S(N)) ) / & (BASQ_TRFV_F(N) + BASQ_TRPV_F(N) + & BASQ_TRFV_L(N) + BASQ_TRPV_L(N) + & BASQ_TRLN_R(N) + BASQ_TRCN_R(N) + & BASQ_TRLN_S(N) + BASQ_TRCN_S(N)) ENDDO ! END LOOP OVER REG 1-12

! SET ANNUAL F/I END-USE PRICES FOR UTILITY SECTOR

SEC=5 DO N=1,DNODES ! NGTDM DMD REGIONS PQ_F(N) = 0.0 ! USED BY UTIL SEC=5 PQ_I(N) = 0.0 ! USED BY UTIL SEC=5 Q_F(N) = 0.0 ! USED BY UTIL SEC=5 Q_I(N) = 0.0 ! USED BY UTIL SEC=5 ENDDO

DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16 N = EMMSUB_NG(J) ! NGTDM REGION 1-12

NGUPR_F(J) = PKSHR_UDMD_F(J) * NGUPR_SF(PKNET,J) + &

(1.-PKSHR_UDMD_F(J)) * NGUPR_SF(OPNET,J) NGUPR_I(J) = PKSHR_UDMD_I(J) * NGUPR_SI(PKNET,J) + &

(1.-PKSHR_UDMD_I(J)) * NGUPR_SI(OPNET,J)

PQ_F(N) = PQ_F(N) + NGUPR_F(J) * BASUQTY_F(J) PQ_I(N) = PQ_I(N) + NGUPR_I(J) * BASUQTY_I(J)Q_F(N) = Q_F(N) + BASUQTY_F(J)

Q_I(N) = Q_I(N) + BASUQTY_I(J) ENDDO

DO N=1,DNODES NGPR_F(SEC,N) = PQ_F(N) / Q_F(N) NGPR_I(SEC,N) = PQ_I(N) / Q_I(N) ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! RESET PREVIOUS DMD AND SUPPLY FOR CONV CHK NEXT CYCLE ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! FUNCTIONS USED: NGDMD_CRVF ! NGDMD_CRVI ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_PREV IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc'

INTEGER*4 N ! DEMAND NODES INTEGER*4 J ! COUNTER INTEGER*4 S ! SUPPLY NODE ID INTEGER*4 SEC ! SECTOR ID

REAL*4 NGDMD_CRVF ! FUNCTION: NONUTILITY DMD CRV REAL*4 NGDMD_CRVI ! FUNCTION: NONUTILITY DMD CRV REAL*4 NGUDMD_CRVF ! FUNCTION: UTILITY DMD CRV REAL*4 NGUDMD_CRVI ! FUNCTION: UTILITY DMD CRV ! --------------

! DO NOT RESET IF EHISYR=LHISYR, AND MODYR=LHISYR

IF (MODYR .GT. EHISYR) THEN ! ---- DO N=1,DNODES ! NGTDM DMD REGIONS

DO SEC=1,DSEC-1 ! DEMAND SECTORS ZNGQTY_F(SEC,N) = 0.0 ZNGQTY_I(SEC,N) = 0.0 ENDDO ENDDO

DO J=1,NNGEM-1 ZNGUQTY_F(J) = 0.0 ZNGUQTY_I(J) = 0.0 ENDDO

DO SEC=1,DSEC-1 ! NONUTILITY DO N=1,DNODES ZNGQTY_F(SEC,N) = & NGDMD_CRVF(SEC,N,NGPR_F(SEC,N)) ! FUNCTION ZNGQTY_I(SEC,N) = & NGDMD_CRVI(SEC,N,NGPR_I(SEC,N)) ! FUNCTIONENDDO

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 YEARSIF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN

NGUDMD_CRVF = BASUQTY_F(SREG) RETURN ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASUQTY_F(SREG) P0 = BASUPR_F(SREG)

NGUDMD_CRVF = Q0 * ((PR / P0) ** UTIL_ELAS_F(SREG))

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! DEMAND CURVE FOR INTERRUPTIBLE UTILITY SERVICE ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGSET_PREV ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = REAL FUNCTION NGUDMD_CRVI(SREG,PR) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc'

INTEGER*4 SREG ! SUBREGION ID

REAL*4 PR ! PRICE ON DMD CURVE REAL*4 Q0 ! BASE QTY (COMP) IN CURVE EQ. REAL*4 P0 ! BASE PR IN CURVE EQ.

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

! SET DMD = CONSTANT IF CURITR=1 -OR- HIST YEARS

IF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN NGUDMD_CRVI = BASUQTY_I(SREG) RETURN ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASUQTY_I(SREG) P0 = BASUPR_I(SREG)

NGUDMD_CRVI = Q0 * ((PR / P0) ** UTIL_ELAS_I(SREG))

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET BASPR AND BASUPR FOR USE BY DMD CURVE FUNCTIONS ! ! STATUS: ! ! CALLED BY: NGTDM_ITM (EVERY ITERATION) ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =SUBROUTINE NGITM_BASPR

IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc'

INTEGER*4 N ! NODE ID INTEGER*4 J ! SUBREGION ID INTEGER*4 SEC ! SECTOR ID

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

DO SEC=1,DSEC-1 DO N=1,DNODES BASPR_F(SEC,N) = NGPR_F(SEC,N) BASPR_I(SEC,N) = NGPR_I(SEC,N) ENDDO ENDDO

DO J=1,NNGEM-1 BASUPR_F(J) = NGUPR_F(J) BASUPR_I(J) = NGUPR_I(J) ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET ACTUAL/FINAL ARC CAPACITIES FOR HIST YEARS ! ACTPCAP ! ! STATUS: COMPLETE ! ! CALLED BY: HNGTDM_ITM ! ! FREQUENCY: EVERY NEMS ITERATION AND HIST YEAR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE HNGSET_ACTPCAP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A ! ARC COUNTER INTEGER*4 SRC ! SRC ID INTEGER*4 DEST ! DEST ID

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

DO A=1,NARCS SRC = ARC_2NODE(A,1) DEST= ARC_2NODE(A,2)

ACTPCAP(A) = CURPCAP(A,MODYR) ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =! ! SET ACTUAL/FINAL ARC CAPACITIES ! ACTPCAP ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! FREQUENCY: EVERY NEMS ITERATION AND YEAR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGSET_ACTPCAP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 A ! ARC COUNTER INTEGER*4 SRC ! SRC ID INTEGER*4 DEST ! DEST ID

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION REAL*4 PK_CAP ! PK EQUIV CAP FOR FLORIDA REAL*4 OP_CAP ! OP EQUIV CAP FOR FLORIDA REAL*4 PCAP ! MAX CAP BETWEEN PK & OP EQUIV CAP REAL*4 MAXPCAP17 ! TOTAL CAPACITY OUT OF NODE 17 (2 arcs) !--------------

MAXPCAP17=0.0 DO A=1,NARCS SRC = ARC_2NODE(A,1) DEST= ARC_2NODE(A,2)

IF ((SRC .EQ. 6) .AND. (DEST .EQ. 10)) THEN ! PIPE TO FLORIDA PKFAC = PKSHR_YR * PKUTZ(A) OPFAC = (1.-PKSHR_YR) * OPUTZ(A)

PK_CAP = FLOW(PKNET,A) / PKFAC OP_CAP = FLOW(OPNET,A) / OPFAC PCAP = AMAX1( PK_CAP, OP_CAP ) ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) )

ELSE IF(SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARCS PCAP = FLOW(PKNET,A) / PKUTZ(A) ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) ) !-EM4 ACTPCAP(A) = AMIN1( ACTPCAP(A), MAXPCAP(PKNET,A) )

MAXPCAP(OPNET,A) = ACTPCAP(A)

ELSE IF (SRC.EQ.17) THEN ! SUM ARCS LEAVING NODE 17 MAXPCAP17=MAXPCAP17+MAXPCAP(OPNET,A) ENDIF IF (DEST.EQ.17) THEN MAXPCAP(OPNET,A) = AMAX1(MAXPCAP(OPNET,A),MAXPCAP17) ENDIF ACTPCAP(A) = MAXPCAP(OPNET,A) ENDIF ENDDO

RETURN END! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! PREPROCESSING ROUTINES: ! - CALL ROUTINE TO SET CONST DMD ! - CALL ROUTINE TO SET MAX CAPACITY ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! FREQUENCY: EVERY NEMS ITERATION AND YEAR ! ! CALLS TO: NGSET_NODECDMD ! NGSET_MAXPCAP ! NGSET_ZOGVAR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE NGITM_PRE IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngcdmdinc'

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

CALL NGSET_NODECDMD ! SET NODE_CDMD: CONST DMD & SUP

IF (CURITR .EQ. 1) THEN CALL NGSET_ZOGVAR ! SET ZOG... VARIABLES FOR ITM USE CALL NGSET_MAXPCAP ! SET MAX CAP ON ALL ARCS ENDIF

RETURN END

!================================================================== ! ! SET CONST DMD AND SUPPLY NET TOTALS: ! NODE_CDMD ! ! STATUS: COMPLETE ! ! CALLED BY: NGITM_PRE ! ! FREQUENCY: EVERY ITERATION OF EVERY YEAR ! ! NOTES: ADGAS CHANGES EVERY NEMS ITERATION ! ALL OTHER CONST SUP/DMD CHANGE EACH YEAR ! ! INPUT VARIABLES: ! YEAR_CDMD(2,24) ! ZADGPRD(12) ! ! OUTPUT VARIABLES: ! NODE_CDMD(2,24) ! !================================================================== SUBROUTINE NGSET_NODECDMD IMPLICIT NONE
include 'parametr' include 'ncntrl'include 'ngparinc'

include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'ngdtminc' include 'ogglobal'

INTEGER*4 L,A ! COUNTERS INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 N,M ! NODE ID INTEGER*4 SRC, DEST ! INTEGER*4 I ! character*5 dum ! ------------- ! if(modyr.eq.1990.and.curitr.eq.1) OPEN(UNIT=69,FILE="ngdebg1.txt") ! if(modyr.eq.1990.and.curitr.eq.1) open(unit=68,file="ngdebg.txt")

DO NET=1,NETWORK DO N=1,TNODES NODE_CDMD(NET,N) = 0.0 MTH_CDMD(NET,N) = 0.0 ! peak month ENDDO ENDDO

CALL NGSET_ADSUP CALL NGSET_FIXSUP ! mvd fr ngset_yearcdmd ! SECD FLOWS, CAN/MEX EXP, MEX IMP, ! TOTAL SUPLMT, LNG, DISC, ANGTS, ! SABLE ISLAND IF (MODYR.GT.LHISYR .OR. CURITR .EQ. 1) THEN ! EVENTUALLY CHECK WHY HIST DIFF IF CALLED WHEN CURITR>1

CALL NGSET_YEARCDMD ENDIF ! PUT INTO CONST DMD VARIABLE DO NET=1,NETWORK DO N=1,TNODES NODE_CDMD(NET,N) = YEAR_CDMD(NET,N) MTH_CDMD(NET,N) = MTHYR_CDMD(NET,N) ! peak month ENDDO ENDDO

! LNG IMPORTS

FIXSUPIP = 0.0
! added 7-1-07 fr previous version by Yelena ! LNG IMPORTS AND CONST ON/OFF SHORE ADGAS !rmv yd1 see above CALL NGSET_ADSUP DO I=1,SNODES N=MAP_NG(I) IF (SUPARRAY(I).EQ.0 .AND. (SUPTYPE(I) .EQ. 3 .OR. &

SUPTYPE(I) .EQ. 7 .OR. SUPTYPE(I) .EQ. 8)) THEN NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - & PKSHR_PROD(I) * ZFIXSUP(I) NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - & (1.-PKSHR_PROD(I)) * ZFIXSUP(I)
if (SUPTYPE(I) .EQ. 3) then dum='lng ' else dum='adgas' endif FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + & PKSHR_PROD(I) * ZFIXSUP(I) FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + & (1.-PKSHR_PROD(I)) * ZFIXSUP(I)! peak month

IF (SUPTYPE(I) .EQ. 3) THEN PPERMTH(PKNET,I)=0.25 PPERMTH(OPNET,I)=.125 ENDIF MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - & (PKSHR_PROD(I) * ZFIXSUP(I) * PPERMTH(PKNET,I)) MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - & ((1.-PKSHR_PROD(I)) * ZFIXSUP(I) * PPERMTH(OPNET,I)) ENDIF ENDDO

! LNG EXPORTS

DO I=1,NLNGIMP N = LNG_XMAP(I,3) M = MNUMBX-4-NLNGIMP+I NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * (1.+PERLIQFUEL))

NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * (1.-PKSHR_ELNG(I)) * (1.+PERLIQFUEL))

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * 0.25 * (1.+PERLIQFUEL))

MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * (1.-PKSHR_ELNG(I))*0.125 * (1.+PERLIQFUEL)) ENDDO NODE_CDMD(PKNET,7) = NODE_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * PKSHR_ELNG(I)) NODE_CDMD(OPNET,7) = NODE_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * (1.-PKSHR_ELNG(I))) MTH_CDMD(PKNET,7) = MTH_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * PKSHR_ELNG(I) * 0.25) MTH_CDMD(OPNET,7) = MTH_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * (1.-PKSHR_ELNG(I))*0.125)

DO I=1,DNODES DO NET=1,NETWORK NODE_CDMD(NET,I) = NODE_CDMD(NET,I) + ((BASQ_TRFV_SL(NET,I)+BASQ_TRPV_SL(NET,I) + &
BASQ_TRLN_SR(NET,I)+BASQ_TRLN_SS(NET,I))*(LNGV_LOSS/(1.-LNGV_LOSS)))

ENDDO MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + ((BASQ_TRFV_SL(PKNET,I)+BASQ_TRPV_SL(PKNET,I) + &

BASQ_TRLN_SR(PKNET,I)+BASQ_TRLN_SS(PKNET,I)) * 0.25 * (LNGV_LOSS/(1.-LNGV_LOSS)))

MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + ((BASQ_TRFV_SL(OPNET,I)+BASQ_TRPV_SL(OPNET,I) + &

BASQ_TRLN_SR(OPNET,I)+BASQ_TRLN_SS(OPNET,I)) * 0.125 * (LNGV_LOSS/(1.-LNGV_LOSS))) ENDDO
!rmv yd1 DO I=1,NLNGIMP !rmv yd1 N = MAPLNG_NG(I) !rmv yd1 NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - & !rmv yd1 PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) !rmv yd1 NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - & !rmv yd1 (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR) !rmv yd1 !rmv yd1 FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + & !rmv yd1 PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) !rmv yd1 FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + & !rmv yd1 (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1 ! peak month !rmv yd1 MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &!rmv yd1 (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * 0.25) !1/4 !! (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * PPERMTH(PKNET,N)) !rmv yd1 MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - & !rmv yd1 ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)* 0.125) !1/8 !! ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)*PPERMTH(OPNET,N)) !rmv yd1 ENDDO

! ADD CONST ON/OFF SHORE ADGAS !rmv yd1 CALL NGSET_ADSUP !rmv yd1 DO I=1,uSNODES ! 1-20 !rmv yd1 IF (SUPARRAY(I).EQ.1 .AND. SUPTYPE(I).LT.3) THEN ! Var conventional supply !rmv yd1 IF (I .LE. NSUPSUB) THEN ! DEFINE L48 REG 1-12 !rmv yd1 N=SUPSUB_NG(I) !rmv yd1 ELSE !rmv yd1 N=SUPSUB_NG(OCSMAP(I-NSUPSUB)) !rmv yd1 ENDIF !rmv yd1 NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - & !rmv yd1 PKSHR_PROD(I) * ZADGPRD(I) !rmv yd1 FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + & !rmv yd1 PKSHR_PROD(I) * ZADGPRD(I) !rmv yd1 NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - & !rmv yd1 (1.-PKSHR_PROD(I)) * ZADGPRD(I) !rmv yd1 FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + & !rmv yd1 (1.-PKSHR_PROD(I)) * ZADGPRD(I) ! peak month !rmv yd1 MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - & !rmv yd1 (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,I)) !by sup reg !! (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,N)) !by ng reg !rmv yd1 MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - & !rmv yd1 ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,I)) !by sup reg !! ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,N)) !by ng reg !rmv yd1 ENDIF !rmv yd1 ENDDO

RETURN END

!================================================================== ! ! SET CONST DMD AND SUPPLY TOTALS: ! YEAR_CDMD ! ! STATUS: COMPLETE ! ! CALLED BY: NGSET_NODECDMD ! ! FREQUENCY: 1ST ITERATION OF EVERY YEAR ! ! INPUT VARIABLES: ! ZTOTSUP(12) defined in NGSET_TOTSUP ! OGQNGIMP from OGSM model ! OGQNGEXP from OGSM model ! OGQANGTS(yr) from OGSM model ! ! OUTPUT VARIABLES: ! ! INCLUDES: ! <>L48 arc secondary flows ! <>import /export arcs (including CAN intermediate arcs) ! <>LNG imports ! <>SNG from liquid ! <>SNG from coal ! <>other supplemental ! <>Sable Island (part of Can const sup) ! >ANGTS ! >split CAN demand into P/O and add to CAN1 node! >split CAN flow-thru into P/O and add to ! ?? border crossing path 3,15,24 only ! >discrepancy ! !================================================================== SUBROUTINE NGSET_YEARCDMD IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'ngptmitm' include 'ngakinc' include 'ogglobal' include 'ngsteoinc'

INTEGER*4 L,A ! COUNTERS INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 N ! NODE ID INTEGER*4 SRC, DEST ! INTEGER*4 I,J,M ! INTEGER*4 BORDER ! NODE AT BORDER CROSSING

REAL*4 PKSHR ! SHR OF FLOW TO PEAK NETWORK

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

DO NET=1,NETWORK DO N=1,TNODES YEAR_CDMD(NET,N) = 0.0 MTHYR_CDMD(NET,N) = 0.0 ENDDO ENDDO

! IN FORECAST YEARS ASSIGN MEX I/E TO SEC FLOW ARRAYS

IF (MODYR.GT.LHISYR) THEN DO I=1,NMEX J = NXMAPUS + I M = NCAN + I L = SNODE_2ARC(MEX_XMAP(I,2),MEX_XMAP(I,1)) SAFLOW(L,MODYR) = oOGQNGIMP(M,CURIYR) L = SNODE_2ARC(MEX_XMAP(I,1),MEX_XMAP(I,2)) SAFLOW(L,MODYR) = oOGQNGEXP(M,CURIYR) ENDDO ENDIF

! SECONDARY FLOWS

DO A=1,SARCS SRC = SARC_2NODE(A,1) DEST= SARC_2NODE(A,2)

IF (SRC .NE. DEST) THEN ! src = lower 48 IF (SRC .LE. DNODES) THEN IF (DEST .LE. DNODES) THEN PKSHR = PKSHR_YR ELSE IF(DEST .LE. DNODES+NCAN_BRD) THEN PKSHR = PKSHR_ECAN ELSE IF(DEST .LE. DNODES+NCAN_BRD+NMEX) THEN PKSHR = PKSHR_EMEX ENDIF! src = canada border

ELSE IF(SRC .LE. DNODES+NCAN_BRD) THEN IF (DEST .LE. DNODES) THEN PKSHR = PKSHR_ICAN ELSE IF(DEST .GT. DNODES+NCAN_BRD+NMEX) THEN PKSHR = PKSHR_ECAN ENDIF ! src = mexico ELSE IF(SRC .LE. DNODES+NCAN_BRD+NMEX) THEN IF (DEST .LE. DNODES) THEN PKSHR = PKSHR_IMEX ENDIF ! src = canada supply ELSE PKSHR = PKSHR_ICAN ENDIF

YEAR_CDMD(PKNET,SRC) = YEAR_CDMD(PKNET,SRC) + & PKSHR * SAFLOW(A,MODYR) YEAR_CDMD(OPNET,SRC) = YEAR_CDMD(OPNET,SRC) + & (1.-PKSHR) * SAFLOW(A,MODYR) YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - & PKSHR * SAFLOW(A,MODYR) YEAR_CDMD(OPNET,DEST) = YEAR_CDMD(OPNET,DEST) - & (1.-PKSHR) * SAFLOW(A,MODYR)

PTNETFLOW(PKNET,SRC,DEST) = PKSHR * SAFLOW(A,MODYR) PTNETFLOW(OPNET,SRC,DEST) = (1.-PKSHR) * SAFLOW(A,MODYR)

! peak month MTHYR_CDMD(PKNET,SRC) = MTHYR_CDMD(PKNET,SRC) + & (PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET)) MTHYR_CDMD(OPNET,SRC) = MTHYR_CDMD(OPNET,SRC) + & ((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET)) MTHYR_CDMD(PKNET,DEST)= MTHYR_CDMD(PKNET,DEST)- & (PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET)) MTHYR_CDMD(OPNET,DEST)= MTHYR_CDMD(OPNET,DEST)- & ((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET))

ENDIF ENDDO

! -SNG FROM LIQ ! -SNG FROM COAL ! -OTHER SUPPLEMENTAL !yd1: IF SUPPLIES ABOVE ARE NO MORE FIXED CHANGE BELOW USING ZFIXSUP VARIABLE CALL NGSET_TOTSUP DO N=1,DNODES YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) - & PKSHR_SUPLM * ZTOTSUP(N) YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) - & (1.-PKSHR_SUPLM) * ZTOTSUP(N) ! peak month MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) - & (PKSHR_SUPLM * ZTOTSUP(N) * 0.25) !1/4 !! (PKSHR_SUPLM * ZTOTSUP(N) * PPERMTH(PKNET,N))

MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) - & ((1.-PKSHR_SUPLM) * ZTOTSUP(N) * 0.125) !1/8 !! ((1.-PKSHR_SUPLM) * ZTOTSUP(N) * PPERMTH(OPNET,N)) ENDDO

! ANGTS

DEST = NODE_ANGTS YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - & PKSHR_YR * QAK_ALB(MODYR)YEAR_CDMD(OPNET,DEST) = YEAR_CDMD(OPNET,DEST) - &

(1.-PKSHR_YR) * QAK_ALB(MODYR) ! peak month MTHYR_CDMD(PKNET,DEST) = MTHYR_CDMD(PKNET,DEST) - & (PKSHR_YR * QAK_ALB(MODYR) * 0.25) !1/4 !! (PKSHR_YR * QAK_ALB(MODYR) * PPERMTH(PKNET,DEST)) MTHYR_CDMD(OPNET,DEST) = MTHYR_CDMD(OPNET,DEST) - & ((1.-PKSHR_YR) * QAK_ALB(MODYR) * 0.125) !1/8 !! ((1.-PKSHR_YR) * QAK_ALB(MODYR) * PPERMTH(OPNET,DEST))

! CANADIAN DMD
! IF (MODYR.GT.LHISYR+2) CALL NGADJ_CNDMD ! wop adjustment after steo years

DO I=1,2 ! EAST & WEST CANADA N=TNODES-LNGNODES-2+I YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) + & PKSHR_CDMD * CN_DMD(I,MODYR) - & PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - & PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR) ! add following and those below if want canada lng exports accounted for in canada production !!!! PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR) add + to previous

YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) + & (1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - & (1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - & (1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR) !!!! (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR) add + to previous ! peak month MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) + (PERMTH(PKNET) * & (PKSHR_CDMD * CN_DMD(I,MODYR) - & PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - & PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR) )) !!!! PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR) )) delete )) from previous and add +

MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) + (PERMTH(OPNET) * & ((1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - & (1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - & (1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR) )) !!!! (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR) )) delete )) from previous and add + ENDDO

! DISCREPANCY (ADD TO DEMAND)

! L48 IF (MODYR .GT. EHISYR) THEN IF (MODYR.GE.STEOYRS(1) .AND. (MODYR.LE.STPHAS_YR.OR.STPHAS_YR.EQ.0)) CALL xNGSTEO_BENCHDISCR

IF (MODYR.EQ.STEOYRS(STEO_YEAR)+1 .AND. STPHAS_YR.EQ.0) CALL xNGSTEO_BENCHDISCR DO N=1,DNODES DO NET=1,NETWORK YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + & DISCR(NET,N,MODYR) ! peak month MTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + & (DISCR(NET,N,MODYR) * PERMTH(NET)) ENDDO ENDDO

! CANADA DO I=1,2 N=TNODES-LNGNODES-2+I DO NET=1,NETWORK YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + CN_DISCR(NET,I) ! peak monthMTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + & (CN_DISCR(NET,I) * PERMTH(NET)) ENDDO ENDDO ENDIF

RETURN END

!================================================================== ! ! ADJUST CANADIAN DEMANDS BASED OFF ENDOGENOUS READ GIVEN RELATIVE PRICE CHANGES ! ! CALLED BY: NGSET_YEARCDMD ! ! FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD ! ! INPUT VARIABLES: CN_DMD, IT_WOP, OGCNPPRD ! ! OUTPUT VARIABLES: CN_DMD ! !==================================================================

SUBROUTINE NGADJ_CNDMD IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngcdmdinc' include 'ogglobal'

REAL*4 A,B,SA,SB,NA,NB REAL*4 BAS_CNPRC(IBASYR:IBASYR+MNUMYR-1) REAL*4 BAS_WOP(IBASYR:IBASYR+MNUMYR-1)
! EM4 TRACK (this subr NGADJ_CNDMD no longer called) DATA BAS_CNPRC /1.20,1.04,0.96,1.08,1.13,0.81,1.05,1.11,0.97, & 1.36,1.98,2.07,1.89,1.79,1.73,1.67,1.62,1.59,1.57,1.55, & 1.55,1.55,1.55,1.56,1.57,1.6,1.65,1.72,1.83,1.98,2.16, & 2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, & 2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, & 2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16/ ! EM4 TRACK (this subr NGADJ_CNDMD no longer called) DATA BAS_WOP /19.58,16.25,15.44,16.36,12.60,13.61,16.06,14.14, 9.12,12.81, &

20.16,15.63,16.64,19.15,24.17,23.47,20.72,18.89,18.06,17.47, & 17.26,17.50,17.74,17.98,18.22,18.47,18.71,18.95,19.19,19.43, & 19.68,19.93,20.18,20.43,20.68,20.93,20.93,20.93,20.93,20.93,20.93, & 20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93, & 20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93/

! DATA BAS_WOP /19.50,16.17,15.38,13.31,12.55,13.55,15.99,14.08,9.08, & ! 12.75,20.10,15.61,16.54,18.31,17.05,16.50,16.61,16.71, & ! 16.81,16.91,17.01,17.11,17.21,17.31,17.42,17.53,17.63, & ! 17.74,17.85,17.96,18.06,18.22,18.38,18.53,18.68,18.84, & ! 18.84,18.84,18.84,18.84,18.84/ INTEGER*4 I

NA = (oIT_WOP(CURIYR-1,1) / BAS_WOP(MODYR-1)) NB = (oOGCNPPRD(2,CURIYR-1) / BAS_CNPRC(MODYR-1)) NB = 0.0 ! temporarily remove impact due to gas price change

! DO I=1,2 ! CN_DMD(I,MODYR) = CN_DMD(I,MODYR) * (NA**0.5) ! ENDDOCN_DMD(2,MODYR) = CN_DMD(2,MODYR) * (NA**0.2)

RETURN END

!================================================================== ! ! ADJUST CANADIAN DEMANDS USING ESTIMATED EQUATION ATTEMPTING ! TO REPRODUCE EXOGENOUS FORECAST ENDOGENOUSLY ! ! CALLED BY: NGSET_YEARCDMD ! ! FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD ! ! INPUT VARIABLES: CN_DMD, IT_WOP, OGCNPPRD ! ! OUTPUT VARIABLES: CN_DMD ! !==================================================================

SUBROUTINE XNGADJ_CNDMD IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngcdmdinc' include 'ogglobal'

REAL*4 A,B

INTEGER*4 I

A = oIT_WOP(CURIYR-1,1) / oIT_WOP(CURIYR-2,1) B = oOGCNPPRD(2,CURIYR-1) / oOGCNPPRD(2,CURIYR-2)

DO I=1,2 ! EM4 TRACK -- routine not used

CN_DMD(I,MODYR) = CN_DMD(I,MODYR-1) * & (1.08 + (0.048*A) + (-0.085*B) + (-0.0011*CURIYR)) ENDDO

RETURN END

!================================================================== ! ! SET TOTAL SUPPLEMENTAL SUPPLIES IN BCF ! - SNG FROM LIQUIDS ! - SNG FROM COAL ! - OTHER SUPPLEMENTAL ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGSET_NODECDMD ! ! FREQUENCY: 1ST ITERATION OF EVERY YEAR ! ! INPUT VARIABLES: ! SNGLIQ(12,yr) defined in NGITM_READINIT ! SNGCOAL(yr) read in from miscdata ! SNGOTH(12,yr) other supplemental ! ! OUTPUT VARIABLES:! ZTOTSUP(12) ! !================================================================== SUBROUTINE NGSET_TOTSUP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc'

INTEGER*4 N ! NODE ID INTEGER*4 I ! LOOP AROUND SUPPLY SOURCE

REAL*4 SUP_TOTAL ! TOTAL SUPPLEMENTAL SUP (CL, LNG, OTH) ! ------------- ! ! -- NGTDM REGIONS -- ! SNGLIQ REGIONS 1 2 3 4 5 6 7 8 9 10 11 12 ! (region 3,12 used) ! NODE_SNGCOAL 4 ! SNGOTH REGIONS 1 2 3 4 5 6 7 8 9 10 11 12 ! DO N=1,DNODES

ZTOTSUP(N) = 0.0 ENDDO

N = NODE_SNGCOAL ! SNG FROM COAL !yd1 CTG ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(MODYR)

! OTHER SUPPLEMENTAL (12) ! SNG FROM LIQUIDS DO N=1,DNODES ZTOTSUP(N) = ZTOTSUP(N) + SNGOTH(N,MODYR) ZTOTSUP(N) = ZTOTSUP(N) + SNGLIQ(N,MODYR) ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(N,MODYR) ENDDO

RETURN END

!================================================================== ! ! SET FIXED SUPPLIES IN BCF ! - SNG FROM LIQUIDS ! - SNG FROM COAL ! - OTHER SUPPLEMENTAL ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGSET_NODECDMD ! ! FREQUENCY: 1ST ITERATION OF EVERY YEAR ! ! INPUT VARIABLES: ! SNGLIQ(12,yr) defined in NGITM_READINIT ! SNGCOAL(12,yr) read in from miscdata ! SNGOTH(12,yr) other supplemental ! oOGQNGIMP LNG IMPORTS ! ZADGPRD(18) AD GAS ! QAK_ALB ALASKA ! CN_FIXSUP(cSNODES) CANADA ! ! OUTPUT VARIABLES: ! ZFIXSUP(91)! PKSHR_PROD(91) ! !================================================================== SUBROUTINE NGSET_FIXSUP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'ogglobal' include 'ngakinc'

INTEGER*4 N,S,P ! CANADA INTEGER*4 I ! LOOP AROUND SUPPLY SOURCE

! ------------- ! DO I=1,SNODES

ZFIXSUP(I) = 0.0 ENDDO

! DO I=1,SNODES ! IF (SUPARRAY(I).EQ.0) THEN ! IF (SUPTYPE(I).EQ.3) PKSHR_PROD(I)=PKSHR_ILNG(SUPRGN(I)) ! IF (SUPTYPE(I).EQ.4.OR.SUPTYPE(I).EQ.5.OR.SUPTYPE(I).EQ.6) PKSHR_PROD(I)=PKSHR_SUPLM ! IF (SUPTYPE(I).EQ.7.OR.SUPTYPE(I).EQ.8) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I)) ! IF (SUPTYPE(I).EQ.9) PKSHR_PROD(I)=PKSHR_YR ! IF (SUPTYPE(I).GE.10) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I)) ! ENDIF ! ENDDO

DO I=1,SNODES IF (I.GT.uSNODES) N=I-uSNODES IF (SUPARRAY(I).EQ.0) THEN IF (SUPTYPE(I).EQ.3 .AND. FIXLNGFLG) ZFIXSUP(I)=oOGQNGIMP(14+SUPREG(I),CURIYR) !LNG IF (SUPTYPE(I).EQ.4) ZFIXSUP(I)=SNGCOAL(SUPREG(I),MODYR) !SUPL FROM COAL

IF (SUPTYPE(I).EQ.5) ZFIXSUP(I)=SNGLIQ(SUPREG(I),MODYR) !SUPL FORM LIQ IF (SUPTYPE(I).EQ.6) ZFIXSUP(I)=SNGOTH(SUPREG(I),MODYR) !SUPL FROM OTH IF (SUPTYPE(I).EQ.7) ZFIXSUP(I)=ZADGPRD(SUPREG(I)) !AD GAS ONSHORE IF (SUPTYPE(I).EQ.8) ZFIXSUP(I)=ZADGPRD(SUPREG(I)+NSRGN(7)) !AD GAS OFFSHORE IF (SUPTYPE(I).EQ.9) ZFIXSUP(I)=QAK_ALB(MODYR) !ALASKA ! IF (SUPTYPE(I).GE.10) ZFIXSUP(I)=CN_FIXSUP(N, MODYR) !CANADA

ENDIF ENDDO

RETURN END

!================================================================== ! ! FILL NG CONSTANST SUPPLY VARIABLES ! ADGPRD(12) -ONSHORE AND OFFSHORE ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGSET_NODECDMD ! ! FREQUENCY: EVERY ITERATION OF EVERY YEAR ! ! INPUT VARIABLES:! OGPRDADON(17,yr) from OGSM model ! OGPRDADOF(3,yr) from OGSM model ! ! OUTPUT VARIABLES: ! ZADGPRD(20) ! !================================================================== ! SUBROUTINE NGSET_ADSUP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'nghistinc' include 'ngsteoinc' include 'ogglobal'

INTEGER*4 I,J ! COUNTERS INTEGER*4 N ! NODE ID ! -------------

! NOTE: ADGAS FOR CANADIAN SUPPLY IS INCLUDED IN VARIABLE SUPPLY

DO J=1,NSRGN(7)+NSRGN(8) ZADGPRD(J) = 0.0 ENDDO

IF (MODYR .LE. EHISYR) THEN DO I=1,NSUPSUB ! ONSHORE AD GAS (17) N = SUPSUB_NG(I) ZADGPRD(I) = ZADGPRD(I) + HOGPRDAD(I,MODYR) * &

(1. - (PCTLP(N)*SCALE_LP(MODYR))) ENDDO

DO I=1,NOCSREG ! OFFSHORE AD GAS (3) J = I+NSUPSUB ! 18-20 N = SUPSUB_NG(OCSMAP(I)) ZADGPRD(J) = ZADGPRD(J) + HOGPRDAD(J,MODYR) * &

(1. - (PCTLP(N)*SCALE_LP(MODYR))) ENDDO

ELSE

DO I=1,NSUPSUB ! ONSHORE AD GAS (17) N = SUPSUB_NG(I) ZADGPRD(I) = ZADGPRD(I) + oOGPRDADON(I,CURIYR) * &

(1. - (PCTLP(N)*SCALE_LP(MODYR))) IF (I.EQ.12) ZADGPRD(I) = ZADGPRD(I) + oOGSHALENG(CURIYR) * &

(1. - (PCTLP(N)*SCALE_LP(MODYR))) ENDDO

DO I=1,NOCSREG ! OFFSHORE AD GAS (3) J = I+NSUPSUB ! 18-20 N = SUPSUB_NG(OCSMAP(I)) ZADGPRD(J) = ZADGPRD(J) + oOGPRDADOF(I,CURIYR) * &

(1. - (PCTLP(N)*SCALE_LP(MODYR))) ENDDO ENDIF RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =! ! PUT OGSM VARIABLES INTO NG ZOG... VARIABLES ! ZOGRESNG ! ZOGPRRNG ! ZOGCCAPPRD ! ZOGTAXPREM ! ! STATUS: PLACEHOLDER ! ! CALLED BY: NGITM_PRE ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGSET_ZOGVAR IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc' include 'nghistinc' include 'ogglobal'

INTEGER*4 I,J,L ! COUNTERS

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

DO I=1,NSUPSUB ! ONSHORE 1-17 IF (CURIYR .GT. 1) THEN ZOGRESNGLAG1(I) = oOGRESNGON(I,CURIYR-1) ZOGPRRLAG(I) = oOGPRRNGON(I,CURIYR-1) ZOGRADNGLAG1(I) = oOGRADNGON(I,CURIYR-1) ENDIF IF (CURIYR .GT. 2) THEN ZOGRESNGLAG2(I) = oOGRESNGON(I,CURIYR-2) ZOGRADNGLAG2(I) = oOGRADNGON(I,CURIYR-2) ENDIF ZOGRESNG(I) = oOGRESNGON(I,CURIYR) ZOGPRRNG(I) = oOGPRRNGON(I,CURIYR) ZOGRADNG(I) = oOGRADNGON(I,CURIYR) ZOGCCAPPRD(I) = oOGCCAPPRD(I,CURIYR) ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR) IF (MODYR.EQ.IBASYR) THEN ZWPROLL = 0.0 ZWPROLL(I,1) = PSUP(I) ZWPRLAG(I) = PSUP(I) ELSEIF (MODYR.EQ.IBASYR+1) THEN ZWPRLAG(I) = HPSUP(I,MODYR) ELSEIF (MODYR.LE.EHISYR) THEN DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = HPSUP(I,MODYR-1) ZWPRLAG(I) = HPSUP(I,MODYR) ELSEIF (MODYR .EQ. EHISYR+1) THEN DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = HPSUP(I,MODYR-1) ZWPRLAG(I) = PSUP(I) ELSE DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = PSUP(I)ZWPRLAG(I) = PSUP(I)

ENDIF ENDDO

DO J=1,NOCSREG ! OFFSHORE 1-3 I = J+NSUPSUB IF (CURIYR .GT. 1) THEN ZOGRESNGLAG1(I) = oOGRESNGOF(J,CURIYR-1) ZOGPRRLAG(I) = oOGPRRNGOF(J,CURIYR-1) ZOGRADNGLAG1(I) = oOGRADNGOF(J,CURIYR-1) ENDIF IF (CURIYR .GT. 2) THEN ZOGRESNGLAG2(I) = oOGRESNGOF(J,CURIYR-2) ZOGRADNGLAG2(I) = oOGRADNGOF(J,CURIYR-2) ENDIF ZOGRESNG(I) = oOGRESNGOF(J,CURIYR) ZOGPRRNG(I) = oOGPRRNGOF(J,CURIYR) ZOGRADNG(I) = oOGRADNGOF(J,CURIYR) ZOGCCAPPRD(I) = 0.0 ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR)

IF (MODYR.EQ.IBASYR) THEN ZWPROLL(I,1) = PSUP(I) ZWPRLAG(I) = PSUP(I) ELSEIF (MODYR.EQ.IBASYR+1) THEN ZWPRLAG(I) = PSUP(I) ELSEIF (MODYR.LE.EHISYR) THEN DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = HPSUP(I,MODYR-1) ZWPRLAG(I) = HPSUP(I,MODYR) ELSEIF (MODYR .EQ. EHISYR+1) THEN DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = HPSUP(I,MODYR-1) ZWPRLAG(I) = PSUP(I) ELSE DO L=IROLL,2,-1 ZWPROLL(I,L) = ZWPROLL(I,L-1) ENDDO ZWPROLL(I,1) = PSUP(I) ZWPRLAG(I) = PSUP(I) ENDIF ENDDO IF (ZOGRESNG(18).GT.0.AND.ZOGRESNGLAG1(18).LT.1.0) ZOGRESNGLAG1(18) = 1.0 ! START UP ATL OCS IF (CURIYR .GT. 1) THEN ZOGRESNGLAG1(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-1) ZOGPRRLAG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR-1) ENDIF IF (CURIYR.GT.2) THEN ZOGRESNGLAG2(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-2) ENDIF ZOGRESNG(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR) ZOGPRRNG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR) ZOGCCAPPRD(SNODES-lSNODES-3) = 0.0 ZOGTAXPREM(SNODES-lSNODES-3) = 0.0

IF (MODYR.EQ.IBASYR) THEN ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3) ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3) ELSEIF (MODYR.EQ.IBASYR+1) THEN ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3) ELSEIF (MODYR .LE.EHISYR) THENDO J=IROLL,2,-1

ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1) ENDDO ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1) ZWPRLAG(SNODES-lSNODES-3) = HPSUP(SNODES-lSNODES-3,MODYR) ELSEIF (MODYR .EQ. EHISYR+1) THEN DO J=IROLL,2,-1 ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1) ENDDO ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1) ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3) ELSE DO J=IROLL,2,-1 ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1) ENDDO ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3) ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3) ENDIF

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET MAXIMUM ALLOWABLE ANNUAL CAPACITY BY ARC ! MAXPCAP ! ! STATUS: COMPLETE ! ! CALLED BY: NGITM_PRE ! ! NOTE: THIS MUST BE CALLED AFTER ZOGRESNG IS SET IN NGSET_ZOGVAR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! SUBROUTINE NGSET_MAXPCAP IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngptmitm' include 'ngsteoinc' include 'ngcdmdinc'

REAL*4 MAXPRRCAN ! MAX P/R FACTOR FOR CANADIAN SUPPLY

INTEGER*4 L,A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 STID ! STORAGE ID (1-14) INTEGER*4 SID ! SUPPLY ID (1-21) INTEGER*4 LID ! NODE ON LNG SUPPLY COUNT (1-3)

INTEGER*4 NG_NREG ! FUNCTION: MAPS SUP REG ID TO NG REG INTEGER*4 NREG ! NG REG ID ! -------------

! IF BUILDS NOT ALLOWED, SET MAXPCAP = CURPCAP, EXCEPT FOR SUPPLY ! IF BUILDS ALLOWED, SET MAXPCAP = PTMAXPCAP OR PTMAXPSTR, EXCEPT SUPPLY

DO L=1,NPROC DEST = PROC_ORD(L)ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2) ! write(6,*) '2nd_LOOP',dest,arc_1,arc_2,l,nproc ENDDO

DO L=1,NPROC DEST = PROC_ORD(L) ! write(6,*) '1st_LOOP',dest,pknet,l,nproc

ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2) DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1)

! NO BUILDS ALLOWED BEFORE NOBLDYR, AND FOR CANADIAN IMPORTS

IF ((MODYR .LE. NOBLDYR) .OR. & ( ((SRC.GT.DNODES) .AND. (SRC.LE.DNODES+NCAN_BRD) .AND. & (DEST.LE.DNODES) .AND. (CNCAPSW.EQ.0)) ) .OR. & ( (DEST.GT.DNODES) .AND. (DEST.LE.DNODES+NCAN_BRD) .AND. & (SRC.EQ.TNODES-LNGNODES .OR. SRC.EQ.TNODES-LNGNODES-1) & .AND. (CNCAPSW.EQ.0) )) THEN

IF ((SRC .LE. TNODES) .OR. & (SRC .GT. (TNODES+SNODES))) THEN ! PIPE & STORAGE MAXPCAP(PKNET,A) = CURPCAP(A,MODYR) ELSE ! SUPPLY SID = SRC - TNODES IF(SUPARRAY(SID).NE.0) THEN NREG = NG_NREG(SID) ! function: NG REG ID ! w/o L&P

IF (MODYR .LE. EHISYR) THEN MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC ELSE IF (SUPTYPE(SID).EQ.14) THEN ! LNG, hardcoded LID = SID-FSRGN(14)+1 ! LNG SUP COUNT (1-3) MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + & !JBEMAX MAXPLNG(LID,OPNET,MODYR) !JBEMAX ELSE MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * & MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR))) ENDIF ENDIF CURPCAP(A,MODYR) = MAXPCAP(PKNET,A) ENDIF ENDIF

ELSE IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS MAXPCAP(PKNET,A) = PTMAXPCAP(SRC,DEST) ELSE IF (SRC .GT. (TNODES+SNODES)) THEN ! STR ARCS STID = SRC - (TNODES+SNODES) ! 1-14 MAXPCAP(PKNET,A) = PTMAXPSTR(STID) ELSE ! SUPPLY ARCS SID = SRC - TNODES IF(SUPARRAY(SID).NE.0) THEN NREG = NG_NREG(SID) ! function: NG REG ID ! w/o L&P IF (MODYR .LE. EHISYR) THEN MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC ELSE IF (SUPTYPE(SID).EQ.10) THEN ! CANADA, hardcoded MAXPRRCAN = 1. + (MAXPRRFAC-1.) * 1.00 MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * & MAXPRRCAN * (1. - (PCTLP(NREG) * SCALE_LP(MODYR))) ELSEIF (SUPTYPE(SID).EQ.14) THEN ! LNG, hardcoded !JBEMAX LID = SID-FSRGN(14)+1 ! LNG SUP COUNT (1-3)MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + & !JBEMAX MAXPLNG(LID,OPNET,MODYR) !JBEMAX ELSE !JBEMAX MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * & MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR))) ENDIF ENDIF ENDIF CURPCAP(A,MODYR) = MAXPCAP(PKNET,A) ENDIF ENDIF MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A) ENDDO ENDDO

RETURN END

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

INTEGER FUNCTION NG_NREG(IREG) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc'

INTEGER*4 IREG ! SUPPLY REG ID (1-17,18-20,21) INTEGER*4 DEST ! TREE NODE INTEGER*4 I ! OCS MAPPING INTO SUP REG ID ! -----------

IF (SUPARRAY(IREG) .NE. 0) THEN NG_NREG = MAP_NG(IREG) IF (IREG .EQ. SNODES - 5) NG_NREG = DNODES+1 ! FOR CAN SUPPLY ENDIF

RETURN END

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

SUBROUTINE NGITM_DEBUG1 IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 L,N,A,I,J,K ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

REAL*4 P0, Q0, QMX ! COST CURVE STARTING PARAMETERS

LOGICAL PRTMAT/.TRUE./

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

! PRINT NEW MATRICES: NODE_2ARC, ARC_2NODE, ARC_LOOP
IF (PRTMAT) THEN ! this print is turned off PRTMAT = .FALSE.IF (TNODES .LT. 25) THEN

K=TNODES ELSE K=25 ENDIF WRITE(NGOERR,*) ' NODE_2ARC: 1 2 3 4 5 6 7 8 9 10 ', & '11 12 13 14 15 16 17 18 19 20 21 22 23 24 25' DO I=1,NODES WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=1,K) ENDDO IF (TNODES .GT. 25) THEN K=TNODES IF (TNODES .GE. 50) K=50 WRITE(NGOERR,*) ' NODE_2ARC:26 27 28 29 30 ... 50' DO I=1,NODES WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=26,K) ENDDO ENDIF IF (TNODES .GT. 50) THEN K=TNODES IF (TNODES .GE. 75) K=75 WRITE(NGOERR,*) ' NODE_2ARC:51 52 53 54 55 ... 75' DO I=1,NODES WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=51,K) ENDDO ENDIF IF (TNODES .GT. 75) THEN K=TNODES IF (TNODES .GE. 100) K=50 WRITE(NGOERR,*) ' NODE_2ARC:76 77 78 79 80 ... 100' DO I=1,NODES WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=76,K) ENDDO ENDIF

WRITE(NGOERR,*) ' ARC_2NODE: SRC DEST' I=1 DO WHILE (ARC_2NODE(I,1) .NE. 0) WRITE(NGOERR,101) I,(ARC_2NODE(I,J),J=1,2) I = I+1 ENDDO

WRITE(NGOERR,*) ' == PEAK == == OFFPEAK ==' WRITE(NGOERR,*) ' ARC_LOOP: START STOP START STOP' DO I=1,TNODES WRITE(NGOERR,102) I,(ARC_LOOP(PKNET,I,J),J=1,2), & (ARC_LOOP(OPNET,I,J),J=1,2) ENDDO ENDIF 100 FORMAT(5X,I2,4X,50(1X,I2)) 101 FORMAT(5X,I2,2X,2(3X,I2)) 102 FORMAT(5X,I2,2X,2(4X,I2),2X,2(4X,I2))

RETURN END

! ======================================================= ! ! REPORT NODE INFO ON ALL NETWORKS (PK, OP) ! ! BKSTOP ! PIPEFUEL ! DEMAND ! SHRPR ! ENDPR! ! =======================================================

SUBROUTINE NGITM_DEBUG2(OUTPUT) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 TDMD ! TOTAL DMD ACROSS ALL NETWORKS (BCF) REAL*4 BK(NETWORK) ! HOLDS BACKSTOP QTY REAL*4 PF(NETWORK) ! HOLDS PIPE FUEL CONSUMPTION

CHARACTER*3 ID ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T) CHARACTER*2 RID(96) ! USED TO TRANSFER VALUE TO CHARACTER CHARACTER*1 CNV(NETWORK)! FLAGS IF NON-CONVERGENCE ON SUPPLY CHARACTER*5 OUTID ! USED TO DISTINGUISH LAST ITR FROM OTHERS CHARACTER*5 HEADID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

DATA RID/'01','02','03','04','05','06','07','08','09','10', &

'11','12','13','14','15','16','17','18','19','20', & '21','22','23','24','25','26','27','28','29','30', & '31','32','33','34','35','36','37','38','39','40', & '41','42','43','44','45','46','47','48','49','50', & '51','52','53','54','55','56','57','58','59','60', & '61','62','63','64','65','66','67','68','69','70', & '71','72','73','74','75','76','77','78','79','80', & '81','82','83','84','85','86','87','88','89','90', & '91','92','93','94','95','96'/ ! -------------

IF (FCRL .EQ. 1) THEN OUTID = 'DB04Z' HEADID = 'DB04X' WRITE(OUTPUT,*) ' DB04X: REPORT NODE LEVEL INFO' ELSE OUTID = 'DB02A' HEADID = 'DB02X' WRITE(OUTPUT,*) ' DB02X: REPORT NODE LEVEL INFO' ENDIF

WRITE(OUTPUT,105) HEADID WRITE(OUTPUT,115) HEADID

DO DEST=1,NODES TDMD = 0.0 DO NET=1,NETWORK TDMD = TDMD + NODE_DMD(NET,DEST) CNV(NET) = ' ' ENDDO IF (DEST .GT. TNODES) THEN DO NET=1,NETWORK BK(NET) = 0.0 PF(NET) = 0.0 ENDDO IF (DEST .LE. TNODES+SNODES) THENI = DEST - TNODES

ID = 'S' // RID(I) ! SUPPLY IF (PSUP_CNVG(PKNET,I) .EQ. 0) CNV(PKNET)= 'X' IF (PSUP_CNVG(OPNET,I) .EQ. 0) CNV(OPNET)= 'X' ENDIF IF (DEST .GT. TNODES+SNODES) THEN I = DEST - (TNODES+SNODES) ID = 'T' // RID(I) ! STORAGE ENDIF ELSE DO NET=1,NETWORK BK(NET) = BKSTOP(NET,DEST) PF(NET) = PFUEL(NET,DEST) ENDDO IF (DEST .LE. DNODES) THEN ID = 'D' // RID(DEST) ! L48 DEMAND NODES ELSE ID = 'I' // RID(DEST) ! CAN/MEX NODES ENDIF ENDIF IF (DEST .LE. TNODES .OR. DEST .GT. TNODES+SNODES) THEN WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, & BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), & CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD ELSEIF (SUPARRAY(DEST-TNODES) .EQ. 1) THEN WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, & BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), & CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD ENDIF ENDDO

105 FORMAT(1X,A5,25X, &

2X,18('-'),' PEAK ',18('-'),7X, & 2X,18('-'),' OFFPEAK ',18('-'), & 2X,'TOTDMD') 115 FORMAT(1X,A5,' YR ITR CYC NODE ', &

'BKSTOP PFUEL NETDMD SHRPR ENDPR', & ' NODE ', & 'BKSTOP PFUEL NETDMD SHRPR ENDPR', & ' TOTDMD') 120 FORMAT(1X,A5,1X,I4, 2(2X,I3), &

2(2X,'|',I3,1X,A3, 3F8.1, F9.3,1X,A1,F9.3), & 2X,F9.1)

RETURN END

! ======================================================= ! ! REPORT ARC LEVEL INFO FOR ALL NETWORKS ! SHR, FLOW, ARC_ENDFEE, ARC,SHRFEE ! ! =======================================================

SUBROUTINE NGITM_DEBUG3(OUTPUT) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE)INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY REAL*4 PKFAC ! FACTOR USE TO CALC EFF CAP REAL*4 TFLO ! TOTAL ANNUAL FLOW ALONG ARC REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

CHARACTER*3 ID ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T) CHARACTER*2 RID(96) ! USED TO TRANSFER VALUE TO CHARACTER CHARACTER*5 OUTID ! USED TO DISTINGUISH LAST ITR FROM OTHERS CHARACTER*5 HEADID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

DATA RID/'01','02','03','04','05','06','07','08','09','10', &

'11','12','13','14','15','16','17','18','19','20', & '21','22','23','24','25','26','27','28','29','30', & '31','32','33','34','35','36','37','38','39','40', & '41','42','43','44','45','46','47','48','49','50', & '51','52','53','54','55','56','57','58','59','60', & '61','62','63','64','65','66','67','68','69','70', & '71','72','73','74','75','76','77','78','79','80', & '81','82','83','84','85','86','87','88','89','90', & '91','92','93','94','95','96'/ ! -------------
IF (NCRL .EQ. 1) THEN ! store flow in PRV var for use next model yr DO NET=1,NETWORK DO A=1,NARCS PRVFLOW(NET,A) = FLOW(NET,A) ENDDO DO DEST=1,TNODES PRVNODE_DMD(NET,DEST) = NODE_DMD(NET,DEST) ENDDO ENDDO RETURN ENDIF

IF (FCRL .EQ. 1) THEN OUTID = 'DB05Z' HEADID = 'DB05X' WRITE(OUTPUT,*) ' DB05X: REPORT ARC LEVEL INFO' ELSE OUTID = 'DB03A' HEADID = 'DB03X' WRITE(OUTPUT,*) ' DB03X: REPORT ARC LEVEL INFO' ENDIF

WRITE(OUTPUT,105) HEADID WRITE(OUTPUT,115) HEADID

DO L=1,NPROC DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2) DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) TFLO = 0.0 DO NET=1,NETWORK MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A) TFLO = TFLO + FLOW(NET,A) ENDDO IF (SRC .GT. TNODES+SNODES) THEN ! storage CUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A) ELSE IF(SRC .LE. TNODES) THEN ! pipeCUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply CUR_EFFCAP(PKNET,A) =MAX_EFFCAP(PKNET,A) ENDIF CUR_EFFCAP(OPNET,A) = MAX_EFFCAP(OPNET,A) IF (SRC .GT. TNODES) THEN IF (SRC .LE. TNODES+SNODES) THEN I = SRC - TNODES ID = 'S' // RID(I) ! SUPPLY ENDIF IF (SRC .GT. TNODES+SNODES) THEN I = SRC - (TNODES+SNODES) ID = 'T' // RID(I) ! STORAGE ENDIF ELSE IF (SRC .LE. DNODES) THEN ID = 'D' // RID(SRC) ! L48 DEMAND NODES ELSE ID = 'I' // RID(SRC) ! CAN/MEX NODES ENDIF ENDIF if (modyr.gt.1990) WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (SRC, ID, DEST, & ARC_SHRFEE(NET,A), ARC_SHRPR(NET,A), SHR(NET,A,MODYR), shr(net,a,modyr-1), &

FLOW(NET,A), CUR_EFFCAP(NET,A), MAX_EFFCAP(NET,A), & NET=1,NETWORK), TFLO ENDDO ENDDO

105 FORMAT(1X,A5,26X, &

3X,20('-'),' PEAK ',20('-'),13X, & 3X,20('-'),' OFFPEAK ',20('-')) 115 FORMAT(1X,A5,' YR ITR CYC SRC DEST ', &

'ARCFEE SHRPR SHR FLOW EFFCAP EFFMAX', & ' SRC DEST ', & 'ARCFEE SHRPR SHR FLOW EFFCAP EFFMAX', & ' TOTFLO') 120 FORMAT(1X,A5,1X,I4, 2(1X,I3), 2(2X,'|',2X,I3, 1X,A3, 1X,I3, &

4F8.3, 3F9.1), 2X,F9.1)

RETURN END

! ! ======================================================= ! SUBROUTINE NGITM_DEBUG6(OUTPUT) IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 DUMMY/0.0/ ! DUMMY VARIABLE

! -------------! REPORT NODE INFO: DMD, SHRPR, ENDPR FOR ALL NETWORKS

WRITE(OUTPUT,*) ' REPORT COST INFO: CYCLE= ',CYCLE WRITE(OUTPUT,105) WRITE(OUTPUT,115)

DO L=1,NPROC DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2) DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) WRITE(OUTPUT,120) CYCLE, SRC, DEST, & (ARC_ENDFEE(NET,A), & NODE_ENDPR(NET,SRC), NODE_ENDPR(NET,DEST), & NODE_SHRPR(NET,SRC), NODE_SHRPR(NET,DEST), & NET=1,2) ENDDO ENDDO DO N=1,SNODES IF (SUPARRAY(N).EQ.1) THEN DEST = TNODES+N SRC = 0 WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, & DUMMY, NODE_ENDPR(NET,DEST), & DUMMY, NODE_SHRPR(NET,DEST), & NET=1,2) ENDIF ENDDO DO N=1,STNODES DEST = TNODES+SNODES+N SRC = 0 WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, & DUMMY, NODE_ENDPR(NET,DEST), & DUMMY, NODE_SHRPR(NET,DEST), & NET=1,2) ENDDO

105 FORMAT(1X,'YR=',14X,20('-'),' PEAK ',20('-'), &

6X,20('-'),' OFFPEAK ',20('-')) 115 FORMAT(1X,'CYCLE', 3X,'NODE', &

7X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', & 9X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', & /8X,'S D',2(20X,'S',7X,'D',9X,'S',7X,'D')) 120 FORMAT(1X,I3, 2X,2I3, 2X,2(3X,F8.2,2(2X,2F8.2)))

RETURN END

! ! ======================================================= ! SUBROUTINE NGITM_DEBUG7(OUTPUT) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc' include 'nghistinc' include 'ngptmitm' ! temp

INTEGER*4 L,N,A,I,J ! COUNTERSINTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE) INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 TDMD ! TOTAL DMD ACROSS ALL NETWORKS (BCF) REAL*4 TFLO ! TOTAL FLO ACROSS ALL NETWORKS (BCF) REAL*4 PKSH ! PKSHR FOR FLOWS/DMDS (FRACTION) REAL*4 DIFFLO ! HAFLOW - TDMD REAL*4 TMAX(NETWORK) ! TOTAL MAX FLO (BCF) REAL*4 DUMMY0/0.0/ ! DUMMY VARIABLE REAL*4 DUMMY1/1.0/ ! DUMMY VARIABLE REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 TEMP ! TEMPORARY HOLDING VARIABLE REAL*4 ATEMP(NXMAPCN) ! TEMPORARY HOLDING VARIABLE

CHARACTER*1 X(NETWORK) ! INDICATOR FOR DMD > QMAX

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

! REPORT NODE INFO: DMD, SHRPR, ENDPR FOR ALL NETWORKS

WRITE(OUTPUT,*) ' REPORT NODE LEVEL INFO: CYCLE= ',CYCLE WRITE(OUTPUT,105) MODYR WRITE(OUTPUT,115)

DO L=1,NPROC DEST = PROC_ORD(L) SRC = 0 ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2)

TDMD = 0.0 DO NET=1,NETWORK TDMD = TDMD + NODE_DMD(NET,DEST) TMAX(NET) = 0.0 DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (NET .EQ. OPNET) THEN ! ???? MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION ENDIF IF ((NET .EQ. OPNET) .AND. (SRC .GT. TNODES+SNODES)) THEN ! DO NOT ADD STORAGE CAPACITY TO OP TMAX ELSE TMAX(NET) = TMAX(NET) + MAXFLO(NET,A) ENDIF ENDDO X(NET)=' ' IF (NODE_DMD(NET,DEST) .GT. TMAX(NET)) THEN X(NET)='X' ENDIF ENDDO IF (TDMD .GT. 0.0) THEN PKSH = NODE_DMD(PKNET,DEST) / TDMD ELSE PKSH = 0.0 ENDIF WRITE(OUTPUT,110) CYCLE, DEST, & (NODE_DMD(NET,DEST), TMAX(NET), X(NET), & NET=1,NETWORK), TDMD, PKSH

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) TFLO = 0.0DO NET=1,NETWORK

TFLO = TFLO + FLOW(NET,A) X(NET)=' ' IF (FLOW(NET,A) .GT. MAXFLO(NET,A)) THEN X(NET)='X' ENDIF ENDDO IF (TFLO .GT. 0.0) THEN PKSH = FLOW(PKNET,A) / TFLO ELSE PKSH = 0.0 ENDIF IF (MODYR .LE. EHISYR) THEN DIFFLO = HAFLOW(A,MODYR) - TFLO ELSE DIFFLO = 0.0 ENDIF WRITE(OUTPUT,120) CYCLE, SRC, DEST, & (SHR(NET,A,MODYR), FLOW(NET,A), MAXFLO(NET,A), X(NET), & NET=1,NETWORK), TFLO, DIFFLO, PKSH ENDDO ENDDO

WRITE(OUTPUT,*) ' XXX SECONDARY CAPACITY' WRITE(OUTPUT,*) ' XXX SRC DEST CAP FLOW'

DO A=1,SARCS SRC = SARC_2NODE(A,1) DEST= SARC_2NODE(A,2) WRITE(OUTPUT,130) SRC,DEST,SACTPCAP(A),SAFLOW(A,MODYR) ENDDO

! temp WRITE(OUTPUT,150) DO L=1,NPROC DEST = PROC_ORD(L) ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2) DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC.LE.TNODES) THEN TEMP = PTMAXPCAP(SRC,DEST) ELSE TEMP = 0.0 ENDIF WRITE(OUTPUT,140) MODYR,SRC,DEST,TEMP, & MAXPCAP(OPNET,A),CURPCAP(A,MODYR),ACTPCAP(A) ENDDO ENDDO 140 FORMAT(1X,'PTMAXPCAP: ',I4,I4,I4,4F10.2) 150 FORMAT(1X,'PTMAXPCAP: YR SRC DEST PTMAXPCAP MAXPCAP CURPCAP ACTPCAP')

! temp IF (MODYR.EQ.LASTYR+IBASYR-1) THEN

WRITE(OUTPUT,*) 'ARC_VARTAR-CN: YEAR 23->13 23->14', & ' 23->15 24->16 24->17 24->18 24->19' DO NET=1,NETWORK WRITE(OUTPUT,*) 'ARC_VARTAR-CN: NET= ',NET DO L=IBASYR,LASTYR+IBASYR-1 DO I=1,NXMAPCN IF (CAN_XMAPCN(I,1).NE.15) THEN ATEMP(I) = ARC_VARTAR(NET,NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1)),L) ELSE ATEMP(I) = 0.0 ENDIF ENDDOWRITE(OUTPUT,160) L, (ATEMP(I),I=1,NXMAPCN) ! WRITE CANADIAN ARC_VARTAR

ENDDO ENDDO ENDIF 160 FORMAT(1X,'ARC_VARTAR-CN: ',I4,8F10.3)

130 FORMAT(1X,'XXX',2I7,2X,2F9.3)

105 FORMAT(1X,'YR=',I4,2X,15X,' PEAK ',19X,' OFFPEAK ') 115 FORMAT(1X,'CYCLE', 2X,'SRC DEST', &

5X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', & 6X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', & 5X,'TDMD',2X,'DIFF',5X,'PKDMD') 110 FORMAT(1X,I3, 6X, I3, 1X,2( 9X, 2(F9.2),A1), &

1X,F9.2,6X,1X,F9.3) 120 FORMAT(1X,I3, 3X,2I3, 1X,2(2X,F7.3, 2(F9.2),A1), &

1X,F9.2,1X,F6.0,F9.3)

RETURN END

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

SUBROUTINE NGTDM_SENSITIVITY(A,B) IMPLICIT NONE

REAL*4 A REAL*4 B

! -------

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! HISTORICAL YEAR VERSION OF NEW INTERSTATE TRANSMISSION MODULE (ITM) ! ! STATUS: ! ! CALLED BY: NGMAIN ! ! CALLS: NGITM_PRE ! PREPROCESSOR ! NGSET_NODEDMD ! SET NET DMDS ! HNGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS ! HNGSET_SUPPR ! SET SUPPLY PR USING CURVE ! NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS ! NGSET_STORPR ! SET STORAGE PRICE ! NGUP_TREE(NET) ! SET NODE PRICE ! NGSET_SECPR ! SET END-USE SECTOR PRICES ! ??? NGSET_PREV ! SET PREV SUP/DMD FOR CONV CHK NXT CYC ! ??? NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ ! ??? NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! SUBROUTINE HNGTDM_ITM IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK! --------------

CALL NGITM_PRE ! PREPROCESSING FOR THE ITM

CALL NGSET_NODEDMD ! SPLIT F/I INTO P/O; ADD CONST DMD

IF (CURITR .EQ. 1) THEN CALL NGHIST_DISCR ! SET DISCREPANCIES ENDIF

CALL HNGDOWN_TREE ! SET HIST SHARES, FLOWS BY SEASON

CALL HNGSET_SUPPR ! SET HIST SUPPLY PRICES BY SEASON

CALL NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

DO NET=NETWORK,1,-1 ! SET NODE & STORAGE PR IF (NET .EQ. PKNET) CALL NGSET_STORPR CALL NGUP_TREE(NET) ENDDO

CALL HNGSET_CGPR ! SET CITYGATE PRICES AND BENCHMARK FAC

!??? CALL NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ CALL HNGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

! DEBUG REPORTS IF (NGDBGITR(4,2) .OR. NGDBGITR(4,12)) THEN CALL NGITM_DEBUG2(NGOTREE) CALL NGITM_DEBUG3(NGOTREE) ENDIF

IF (NGDBGITR(4,1) .OR. NGDBGITR(4,11)) THEN CALL NGITM_DEBUG7(NGOBAL) ENDIF

RETURN END

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

! SET SEASONAL DISCREPANCIES TO BALANCE SUPPLY AND DEMAND (L48) ! FIRST BALANCE CANADA ! CALLED IF CURITR.EQ.1 .AND. MODYR.LE.EHISYR

!========================================================================= SUBROUTINE NGHIST_DISCR IMPLICIT NONE ! include 'parametr' include 'ncntrl' include 'ngparinc' include 'nghistinc' include 'ngcdmdinc' include 'ngitminc' include 'ngtdminc'

REAL*4 PKDISCR ! DISCREPANCY IN THE PEAK PERIOD REAL*4 OPDISCR ! DISCREPANCY IN THE OFFPEAK PERIOD REAL*4 NATDISCR ! NATIONAL ANNUAL DISCREPANCY REAL*4 REGADJ ! REGIONAL ADJUSTMENT OF REGIONAL ANNUAL DISCREPANCY REAL*4 PKADJ ! REGIONAL DIFFERENCE PEAK DISCREANCY AND ANNUAL DISCR

INTEGER*4 A ! ARC INTEGER*4 AI ! IMPORT ARC INTEGER*4 AE ! EXPORT ARCINTEGER*4 NET ! NETWORK INDEX

INTEGER*4 I,J,K,L,M ! GENERIC INDICES

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

! SET DISCREPANCY FOR PEAK/OFFPEAK AND EAST/WEST CANADA

DO M=1,2 ! EAST=1, WEST=2 HCN_DISCR(PKNET,M,MODYR) = HNETWTH(STNODES-2+M,MODYR) - & NODE_DMD(PKNET,TNODES-LNGNODES-2+M) HCN_DISCR(OPNET,M,MODYR) = -1.* HNETINJ(STNODES-2+M,MODYR) - & NODE_DMD(OPNET,TNODES-LNGNODES-2+M) ENDDO HCN_DISCR(PKNET,2,MODYR) = HCN_DISCR(PKNET,2,MODYR) + & (QSUP(SNODES-lSNODES-3) * PKSHR_PROD(SNODES-lSNODES-3) ) HCN_DISCR(OPNET,2,MODYR) = HCN_DISCR(OPNET,2,MODYR) + & (QSUP(SNODES-lSNODES-3) * (1. - PKSHR_PROD(SNODES-lSNODES-3)) )

DO I=1,NXMAPCN AI = NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1)) AE = SNODE_2ARC(CAN_XMAPCN(I,1),CAN_XMAPCN(I,2)) IF (CAN_XMAPCN(I,2) .EQ. TNODES-LNGNODES) THEN M = 2 HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - & ( HAFLOW(AI,MODYR) * PKSHR_ICAN) HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - & ( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) ) ELSE M = 1 IF (I .NE. 3) THEN HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - & ( HAFLOW(AI,MODYR) * PKSHR_ICAN ) HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - & ( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) ) ENDIF ENDIF ENDDO

! SPREAD DISCREPANCY IN EACH SEASON EVENLY BETWEEN EAST AND WEST ! AND ADJUST NODE DEMAND TO ACCOUNT FOR DISCREPANCY

PKDISCR = HCN_DISCR(PKNET,1,MODYR) + HCN_DISCR(PKNET,2,MODYR) OPDISCR = HCN_DISCR(OPNET,1,MODYR) + HCN_DISCR(OPNET,2,MODYR) DO M=1,2 HCN_DISCR(PKNET,M,MODYR) = PKDISCR / 2. HCN_DISCR(OPNET,M,MODYR) = OPDISCR / 2. ! ADJUST HAFLOW BTWN 24-23 IF (M .EQ. 1) THEN A=NODE_2ARC(24,23) HAFLOW(A,MODYR) = HAFLOW(A,MODYR) + HCN_DISCR(PKNET,M,MODYR) + & HCN_DISCR(OPNET,M,MODYR) ENDIF ! ADJUST NODE_DMD FOR DISCR I = TNODES-LNGNODES-2+M NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + & HCN_DISCR(PKNET,M,MODYR) NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + & HCN_DISCR(OPNET,M,MODYR) NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + & HCN_DISCR(PKNET,M,MODYR) NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + & HCN_DISCR(OPNET,M,MODYR) YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + & HCN_DISCR(PKNET,M,MODYR) YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + & HCN_DISCR(OPNET,M,MODYR)ENDDO

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

! DETERMINE L48 NATIONAL DISCREPANCY IN THE PEAK AND OFFPEAK PERIODS

! ADD ADJUSTMENT FOR 8->4 AND 8->9 TRANSFER TO 17->4 AND 18->9

IF (MODYR .LT. LHISYR) THEN HBAL_ITM(9,MODYR) = HBAL_ITM(9,MODYR) + DEL_DISCR9(MODYR) HBAL_ITM(4,MODYR) = HBAL_ITM(4,MODYR) + DEL_DISCR4(MODYR) HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR9(MODYR) HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR4(MODYR) ELSE IF (MODYR .EQ. LHISYR) THEN DO I=1,DNODES HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR-1) ENDDO ENDIF

! SUM INTO NATIONAL PEAK AND OFFPEAK DISCREPANCY

PKDISCR = 0.0 OPDISCR = 0.0 NATDISCR = 0.0 ! CANADIAN IMPORTS DO I=1,NXMAPUS IF (I .NE. 3) THEN J = NODE_2ARC(CAN_XMAPUS(I,2),CAN_XMAPUS(I,1)) PKDISCR = PKDISCR + (HAFLOW(J,MODYR) * PKSHR_ICAN) OPDISCR = OPDISCR + (HAFLOW(J,MODYR) * (1.-PKSHR_ICAN)) ENDIF ENDDO ! L48 NA PRODUCTION DO I=1,uSNODES IF (SUPARRAY(I) .EQ. 1) THEN PKDISCR = PKDISCR + (QSUP(I) * PKSHR_PROD(I)) OPDISCR = OPDISCR + (QSUP(I) * (1.-PKSHR_PROD(I))) ENDIF ENDDO ! LNG IMPORTS WHEN NOT FIXED IF (.NOT.FIXLNGFLG) THEN DO I=1,NLNGTER-3 A = NODE_2ARC(LNG_XMAP(I,2),LNG_XMAP(I,3)) PKDISCR = PKDISCR + FLOW(PKNET,A) OPDISCR = OPDISCR + FLOW(OPNET,A) ENDDO ENDIF

! REMAINDER NATDISCR = 0.0 DO I=1,DNODES PKDISCR = PKDISCR - PFUEL(PKNET,I) + HNETWTH(I,MODYR) - & NODE_DMD(PKNET,I) OPDISCR = OPDISCR - PFUEL(OPNET,I) - HNETINJ(I,MODYR) - & NODE_DMD(OPNET,I) NATDISCR = NATDISCR + HBAL_ITM(I,MODYR) ENDDO

! ADJUST NGA BALANCING ITEM IF PEAK AND OFFPEAK SUM DON'T EXACTLY EQUAL

REGADJ = (NATDISCR - (PKDISCR + OPDISCR)) / FLOAT(DNODES)

DO I=1,DNODES HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR) - REGADJ ENDDO! DISTRIBUTE PEAK AND OFFPEAK DISCREPANCY OVER REGIONS, BY ADJUSTING ! ANNUAL REGIONAL DISCREPANCY

PKADJ = ((PKDISCR - OPDISCR) / FLOAT(DNODES) ) / 2. DO I=1,DNODES DISCR(PKNET,I,MODYR) = (HBAL_ITM(I,MODYR) / 2.) + PKADJ DISCR(OPNET,I,MODYR) = HBAL_ITM(I,MODYR) - DISCR(PKNET,I,MODYR)

NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + DISCR(PKNET,I,MODYR) NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + DISCR(OPNET,I,MODYR) NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR) NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR) YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR) YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR) ENDDO

RETURN END

! ================================================================== ! ! SET SHARE OF FLOWS ALONG PIPE ARCS ONLY ! PSHR ! ! STATUS: ! ! CALLED BY: HNGDOWN_TREE ! ! =================================================================

SUBROUTINE XNGSHR_PIPE(NET,DEST,PSHR) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc'

INTEGER*4 A ! ARC COUNTER INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 SRC, DEST ! NODE ID INTEGER*4 NET ! PK/OP NETWORK ID

REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE REAL*4 TPFLOW(NETWORK) ! HOLDS TOTAL FLOW ALONG PIPE ! ----------

TPFLOW(NET) = 0.0 ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY TPFLOW(NET) = TPFLOW(NET) + FLOW(PKNET,A)+ & FLOW(OPNET,A) ENDIF ENDDO

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY PSHR(NET,A) = (FLOW(PKNET,A)+FLOW(OPNET,A)) &

/ TPFLOW(NET)ENDIF

ENDDO

RETURN END

! ================================================================== ! ! SET VARIABLES NEEDED FOR FORECAST YEARS ! FLOW ! SHR ! HPFUEL_FAC (used to set PFUEL_FAC) ! ARC_PFUEL ! ! STATUS: ! ! CALLED BY: HNGTDM_ITM ! ! =================================================================

SUBROUTINE HNGDOWN_TREE IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc' include 'ngcdmdinc'

INTEGER*4 A ! ARC COUNTER INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 SRC, DEST ! NODE ID INTEGER*4 NET, NET0 ! PK/OP NETWORK ID INTEGER*4 L,STID ! COUNTER INTEGER*4 CAPFLG ! FLAG TO CONTINUE CHK FOR FLO ADJ DUE TO CAP INTEGER*4 CHKCHNG ! FLG TO ADJ FLOWS ON OTHER NET INTEGER*4 CHKOLD ! FLG FROM PREV NET ADJ INTEGER*4 CNT ! COUNTER TO PREVENT INF LOOP

REAL*4 PNODE_DMD(NETWORK) ! NODE DMD FOR PIPE ARCS REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE REAL*4 TPNODE_DMD ! ANNUAL NODE DMD FOR PIPE ARCS REAL*4 THAFLOW ! TOTAL FLOW ALONG PIPE INTO NODE REAL*4 NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 FAC(DNODES) ! SEASONAL PK/OP NET NODE DMD SHARE REAL*4 FLO_ADJ ! ADJUSTMENT TO HAFLOW FOR HIST YRS ! ----------

DO L=1,NPROC DEST = PROC_ORD(L)

! ADD PIPEFUEL TO NODE_DMD AND SET PFUEL FACTOR (HPFUEL_FAC) ! SET HISTORICAL INTRAREG FLOW FACTOR (HFLO_FAC)

DO NET=1,NETWORK ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

! ADD NET INJECTIONS TO OFFPEAK DMDS DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF ( (NET .EQ. PKNET) .AND. (SRC .GT. (TNODES+SNODES))) THEN STID = SRC - (TNODES+SNODES) NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + &HNETINJ(STID,MODYR)

ENDIF ENDDO ! DEFINE INTRAREGIONAL FLOW FACTOR AND FLOWS ! HFLO_FAC = INTRA_FLO / NODE_DMD(W/O PF) IF (DEST .LE. DNODES) THEN IF (NET .EQ. PKNET) THEN FAC(DEST) = NODE_DMD(PKNET,DEST) / & (NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST)) ELSE FAC(DEST) = NODE_DMD(OPNET,DEST) / & (NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST)) ENDIF A = SNODE_2ARC(DEST,DEST) INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR) HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / & NODE_DMD(NET,DEST) ENDIF NODE_DMD(NET,DEST) = NODE_DMD(NET,DEST) + PFUEL(NET,DEST)

! TEMPCODE: 09/03/97

INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST) ! TEMPCODE: 09/03/97

IF (NODE_DMD(NET,DEST)-PFUEL(NET,DEST) .GT. 0.) THEN HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / &

(NODE_DMD(NET,DEST) + FIXSUPIP(NET,DEST) - PFUEL(NET,DEST)) ELSE HPFUEL_FAC(NET,DEST,MODYR) = 0.0 ENDIF PNODE_DMD(NET) = NODE_DMD(NET,DEST)

! ADJUST NODE DMD TO BE NET OF SUPPLY AND STORAGE ! (NODE DMD FOR PIPE ARCS ONLY)

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .GT. TNODES) THEN PNODE_DMD(NET) = PNODE_DMD(NET) - FLOW(NET,A) ENDIF ENDDO IF (NGDBGITR(4,6)) THEN IF (PNODE_DMD(NET) .LE. -0.001) THEN WRITE(NGOERR,*) 'ATTN1 HNGDOWN_TREE: NET,DEST,MODYR=', & NET,DEST,MODYR,' PNODE_DMD= ',PNODE_DMD(NET) ENDIF ENDIF ENDDO

! CHECK TOTAL HAFLOWS FOR PIPE ARCS AGAINST TOTAL PNODE_DMD

ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2) THAFLOW = 0.0 DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN THAFLOW = THAFLOW + HAFLOW(A,MODYR) ENDIF ENDDO TPNODE_DMD = PNODE_DMD(PKNET)+PNODE_DMD(OPNET)

IF (NGDBGITR(4,6)) THEN IF (ABS(TPNODE_DMD - THAFLOW) .GT. 0.01) THEN WRITE(NGOERR,*) ' ATTN6 HNGDOWN_TREE: DEST,MODYR= ', & DEST,MODYR,' TPNODE_DMD= ', TPNODE_DMD,' THAFLOW= ', & THAFLOW ENDIFENDIF

! ADJUST HAFLOW TO BETTER MATCH DEMANDS

!CCC IF (MODYR .EQ. LHISYR) THEN

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF ((SRC .GT. DNODES) .AND. (SRC .LE. (TNODES-LNGNODES-2))) THEN THAFLOW = THAFLOW - HAFLOW(A,MODYR) TPNODE_DMD = TPNODE_DMD - HAFLOW(A,MODYR) ENDIF ENDDO IF (THAFLOW .GT. 0.0) THEN FLO_ADJ = TPNODE_DMD / THAFLOW DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. DNODES) THEN !CCC IF ( (SRC .LE. DNODES) .OR. !CCC * ((DEST.GT.(TNODES-2)) .OR. (DEST.LE.TNODES))) THEN

HAFLOW(A,MODYR) = HAFLOW(A,MODYR) * FLO_ADJ ENDIF ENDDO ENDIF !CCC ENDIF

! DETERMINE SHARES AMONG PIPE ARCS ONLY FOR PK NETWORK

CALL HNGSHR_PIPE(PKNET,DEST,PSHR)

! SET PK FLOWS ALONG PIPE ARCS

ARC_1 = ARC_LOOP(PKNET,DEST,1) ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN FLOW(PKNET,A) = PSHR(PKNET,A) * PNODE_DMD(PKNET) ENDIF ENDDO

! CHECK FLOWS AGAINST MAX EFF CAPACITY ON EACH NETWORK ! AND RESET FLOWS ALONG PIPE ARCS

CAPFLG = 1 CHKOLD = 1 NET = 0 CNT = 1

DO WHILE ((CAPFLG .EQ. 1) .AND. (CNT .LE. 5)) IF (NET .EQ. PKNET) THEN NET = OPNET NET0= PKNET ELSE NET = PKNET NET0= OPNET ENDIF

CALL HNGCHK_PIPFLO(NET,DEST,PNODE_DMD(NET),CHKCHNG)

IF ((CHKCHNG .EQ. 0) .AND. (CHKOLD .EQ. 0)) THEN CAPFLG = 0 ELSE CAPFLG = 1 CHKOLD = CHKCHNGARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2) DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN FLOW(NET0,A) = HAFLOW(A,MODYR) - FLOW(NET,A) ENDIF ENDDO ENDIF

CNT = CNT + 1 ENDDO

IF (CAPFLG .EQ. 1) THEN WRITE(NGOERR,*) 'ATTN2 HNGDOWN_TREE: MAX EFF CAP REACHED ', & 'ON ALL ARCS FOR NODE ',DEST,' ITR=',CURITR,' YEAR=',MODYR ENDIF

! REDEFINE SHARES AMONG PIPE ARCS ONLY

CALL HNGSHR_PIPE(PKNET,DEST,PSHR) CALL HNGSHR_PIPE(OPNET,DEST,PSHR)

! SET PFUEL ALONG PIPE ARCS ! SET SHR ALONG ALL INPUT ARCS

DO NET=1,NETWORK ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ARC_PFUEL(NET,A) = PSHR(NET,A) * & (PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST)) ENDIF

IF (SRC.GT.TNODES.AND. SRC.LE.TNODES+SNODES) THEN IF(SUPARRAY(SRC-TNODES).NE.0) THEN IF (ARC_1.EQ.ARC_2) THEN SHR(NET,A,MODYR) = 1.0 ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST) ELSE SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) ENDIF NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A) ENDIF ELSE IF (ARC_1.EQ.ARC_2) THEN SHR(NET,A,MODYR) = 1.0 ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST) ELSE SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) ENDIF NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A) ENDIF

! DETERMINE REMAINING FLOW ALONG ARCS

FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A) ENDDO BKSTOP(NET,DEST) = 0.0 ENDDO ENDDORETURN

END

! ================================================================== ! ! SET SHARE OF FLOWS ALONG PIPE ARCS ONLY ! PSHR ! ! STATUS: ! ! CALLED BY: HNGDOWN_TREE ! ! =================================================================

SUBROUTINE HNGSHR_PIPE(NET,DEST,PSHR) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc'

INTEGER*4 A ! ARC COUNTER INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 SRC, DEST ! NODE ID INTEGER*4 NET ! PK/OP NETWORK ID

REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE REAL*4 TPFLOW(NETWORK) ! HOLDS TOTAL FLOW ALONG PIPE ! ----------

TPFLOW(NET) = 0.0 ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY TPFLOW(NET) = TPFLOW(NET) + FLOW(NET,A) ENDIF ENDDO

DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY IF (TPFLOW(NET).NE. 0.0) THEN PSHR(NET,A) = FLOW(NET,A) / TPFLOW(NET) ELSE PSHR(NET,A) = 0.0 ENDIF ENDIF ENDDO

RETURN END

! ================================================================== ! ! CHECK FLOWS AGAINST MAX EFFECTIVE CAPACITY FOR PIPE ARCS ONLY ! ON EACH NETWORK ! ! STATUS: ! ! CALLED BY: HNGDOWN_TREE! ! =================================================================

SUBROUTINE HNGCHK_PIPFLO(NET,DEST,PDMD,CHKCHNG) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 A ! COUNTERS INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES INTEGER*4 CHKCHNG ! FLAGS IF ANY FLOW CHANGE WAS MADE INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD) INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC REAL*4 SUMFLO ! TOTAL FLOWS NOT AT MAX REAL*4 SUMMAX ! TOTAL FLOWS AT MAX REAL*4 SUMREM ! TOTAL FLOWS REMAINING FOR DISTRIBUTION REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE REAL*4 PDMD ! NODE DMD FOR PIPE ARCS REAL*4 DELTA ! FLOW ADJUSTMENT QUANTITY REAL*4 UTZ ! UTILZ FOR SEASON REAL*4 CMAX ! MAXIMUM AVAILABLE PIPEFLOW BY ARC

! ---------

ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2)

! SET MAXIMUM FLOWS AND TOTAL FLOWS

TMAXFLO = 0.0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) OLDFLG(A) = 0. MAXFLG(A) = 0. MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY !CC IF (NET .EQ. PKNET) THEN !CC UTZ = PKUTZ(A) !CC ELSE IF (NET .EQ. OPNET) THEN !CC UTZ = OPUTZ(A) !CC ENDIF !CC CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A))

CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A)) TMAXFLO = TMAXFLO + CMAX ENDIF ENDDO

! CHECK IF TOTAL FLOWS LESS THAN MAXIMUM FLOWS

CHKCHNG = 0 IF (PDMD .LE. TMAXFLO+.001) THEN ! DMD < TMAXFLO CHNG = 1 DO WHILE (CHNG .EQ. 1) CHK = 0 DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCSSRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY

! CHECK IF ARC FLOW GREATER THAN MAX

IF (FLOW(NET,A) .GE. MAXFLO(NET,A)) THEN DELTA = FLOW(NET,A) - MAXFLO(NET,A) ! SET FLOW = MAX FLOW FLOW(NET,A) = MAXFLO(NET,A) ! ADJUST CORRESP OP FLOW MAXFLG(A) = 1 IF (MAXFLG(A) .NE. OLDFLG(A)) THEN CHK = 1 CHKCHNG = 1 OLDFLG(A) = MAXFLG(A) ENDIF ENDIF ENDIF ENDDO

! IF FLOWS HAVE BEEN ADJUSTED, NEED TO REALLOCATE OVER OTHER ARCS

IF (CHK .EQ. 1) THEN SUMMAX = 0.0 SUMREM = 0.0 SUMFLO = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY IF (MAXFLG(A) .EQ. 0) THEN SUMFLO = SUMFLO + FLOW(NET,A) ELSE SUMMAX = SUMMAX + FLOW(NET,A) ENDIF ENDIF ENDDO SUMREM = PDMD - (SUMFLO+SUMMAX) ! DISTRIBUTE OVER UNCONSTR ARCS DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS SRC = ARC_2NODE(A,1) IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY IF (MAXFLG(A) .EQ. 0) THEN IF (SUMFLO .GT. 0.) THEN DELTA = (SUMREM * (FLOW(NET,A) / SUMFLO)) ELSE DELTA = 0.0 ENDIF ! SET FLOW = MAX FLOW FLOW(NET,A) = FLOW(NET,A) + DELTA ! ADJUST CORRESP OP FLOW ENDIF ENDIF ENDDO ELSE CHNG = 0 ENDIF ENDDO

ELSE ! DMD GREATER THAN EFFECTIVE CAPACITY

IF (NGDBGITR(4,6)) THEN WRITE(NGOERR,*) 'ATTN3 NGCHK_MAXFLO: PIPE DMD > MAX EFF CAP ', & 'FOR NET,NODE,ITR,YEAR:',NET,DEST,CURITR,MODYR, & ' PNDOE_DMD, MAX: ', PDMD, TMAXFLO ENDIF ENDIFRETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET SUPPLY WELLHEAD PRICES BY REGION AND PEAK ! ! STATUS: COMPLETE ! ! CALLED BY: HNGTDM_ITM ! ! CALLS : NGSET_SUPPR ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE HNGSET_SUPPR IMPLICIT NONE
include 'parametr' include 'ngparinc' include 'ngitminc' include 'ngtdminc'

INTEGER*4 N,S ! COUNTERS INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP) ! -----------

DO NET=1,NETWORK DO N=1,NODES NODE_ENDPR(NET,N) = 0.0 NODE_SHRPR(NET,N) = 0.0 ENDDO ENDDO

DO NET=1,NETWORK DO S=1,SNODES N = TNODES + S IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N) ENDDO ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

CALL NGSET_SUPPR

DO NET=1,NETWORK DO S=1,SNODES IF (SUPARRAY(S).EQ.1) THEN N = TNODES + S NODE_ENDPR(NET,N) = NODE_PSUP(NET,S) NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S) NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S) ENDIF ENDDO ENDDO

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SET BENCHMARK FACTORS FOR CITYGATE, MEX, LNG PRICES ! AND SET CITYGATE PRICES FOR EACH PK/OP NETWORK !! STATUS: COMPLETE ! ! CALLED BY: HNGTDM_ITM ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = = SUBROUTINE HNGSET_CGPR IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'nghistinc' include 'ngptmitm' include 'ogglobal'

INTEGER*4 N ! DEMAND NODES INTEGER*4 NET ! REPRESENTS PK/OP NETWORKS

REAL*4 NGPIPE_VARTAR ! FUNCTION (from ptm) REAL*4 TEMP ! TEMPORARILY HOLD INTRA VARTAR ! -------------

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES DO NET=1,NETWORK ! LOOP OVER PK/OP NETWORKS INTRAREG_TAR(NET,N) = INTRAREG_FIXTAR(NET,N) + &

NGPIPE_VARTAR(NET,NARCS+N,INTRA_FLO(NET,N,MODYR)) ! PTM function

!CCC TEMP = INTRAREG_TAR(NET,N) - INTRAREG_FIXTAR(NET,N) !CCC WRITE(4,1000) MODYR,NET,N,INTRAREG_FIXTAR(NET,N), !CCC * TEMP,INTRAREG_TAR(NET,N),INTRA_FLO(NET,N,MODYR) !1000 FORMAT(' INTRAH',I4,2I3,3F6.3,F10.2)

CGPR(NET,N) = NODE_ENDPR(NET,N) + INTRAREG_TAR(NET,N) + &

INTRAST_TAR(N) HCG_BENCH(NET,N,MODYR) = HCGPR(NET,N,MODYR) - CGPR(NET,N) CGBENCH(NET,N) = HCG_BENCH(NET,N,MODYR) ENDDO ENDDO

CALL NGDBUG_DTM03(0)

RETURN END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! SUBROUTINE TO RESET PREVIOUS YEAR'S SHARES IN ANTICIPATION OF ! PLANED CAPACITY BUILDS ! ! STATUS: COMPLETE ! ! CALLED BY: NGMAIN ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGPCAP_ADJSHR IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngtdminc' include 'ngitminc' include 'ngcdmdinc'include 'ngakinc'

include 'ogglobal'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK INTEGER*4 A,A2,I ! COUNTER INTEGER*4 ARC_0 ! ARC FROM CANADA W/ANGTS FLOW INTEGER*4 ARC_1 ! FIRST ARC INTO DEST INTEGER*4 ARC_2 ! LAST ARC INTO DEST INTEGER*4 DEST ! DESTINATION NODE INDEX INTEGER*4 SRC ! SOURCE NODE INDEX INTEGER*4 AKPIP ! SET TO 1 IF CH IN ANGTS VOLS, ELSE 0 INTEGER*4 A16,A17,A9 ! ARCS FOR 16->4 AND 17->4 AND 9->12 INTEGER*4 SRG ! SUPPLY REGION 1-20 INTEGER*4 ORG ! OFFSHORE REGION 1-3 INTEGER*4 ASUP ! ARC CORRESPONDING TO SUPPLY CURVE BEING ADJUSTED

REAL*4 SHRSUM ! SUM OF ADJUSTED SHARES INTO A NODE REAL*4 TOTFLW ! LAST YEAR'S TOTAL FLOW INTO A NODE REAL*4 CHQAK_ALB ! ANNUAL CHANGE IN ANGTS VOLUMES REAL*4 PRDEXP ! INITAL GUESS AT BIG INCREASE IN PRODUCTION LEVELS (EXPECTED PRODUCTION) REAL*4 PRDEXPLAG ! PRDEXP LAGGED REAL*4 PRDCHG ! RATIO OF THIS YEAR TO LAST YEAR'S EXPECTED PRODUCTION REAL*4 SHR1617 ! SUM OF REVISED SHARES FR 16->4 AND 17->4 REAL*4 FLDEL16,FLDEL17,FLDEL18,FLDEL19 ! EST INCR IN FLW ON BRD ARCS ATTRIBUTED TO ANGTS

LOGICAL ONCE ! SET TO FALSE IF RESERVES START IN ATLANTIC OFFSHORE DATA ONCE /.TRUE./

!------------------------------- ! SET ANGTS VOLUME INCREASE

CHQAK_ALB = QAK_ALB(MODYR) - QAK_ALB(MODYR-1) + QMD_ALB(MODYR) - QMD_ALB(MODYR-1)

! ADJUSTMENT FOR ARCS NOT RELATED TO ANGTS

DO NET=1,NETWORK DO A=1,NARCS SRC = ARC_2NODE(A,2) DEST = ARC_2NODE(A,1) IF ( (DEST.LE.DNODES .OR. DEST.EQ.23 .OR. DEST.EQ.24) .AND. & !YD1LNG: LNG ARCS WILL BE ADJSUTED HERE

(ACTPCAP(A)+PLANPCAP(A,MODYR)).GT.0.001 ) THEN IF ( CHQAK_ALB.LE.0.001 .OR. & SRC.GT.(DNODES+NXMAPCN) .OR. SRC.LE.(DNODES+3) ) THEN IF (SHR(NET,A,MODYR-1).GE.0.00001) THEN SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * & ( ACTPCAP(A) + (PLANPCAP(A,MODYR)*PCTADJSHR) ) / ACTPCAP(A) ELSE ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) TOTFLW = 0.0 DO A2 = ARC_1,ARC_2 TOTFLW = TOTFLW + FLOW(NET,A2) ENDDO SHR(NET,A,MODYR-1) = (PLANPCAP(A,MODYR)*0.15) / TOTFLW ! YD1 (REALLY JBE) INITIALIZE LNG IF ZERO

ARC_SHRPR(NET,A) = NODE_SHRPR(NET,DEST) ENDIF ENDIF ENDIF ENDDO

DO DEST=1,DNODES ! SCALE SO SUM SHARES ADDS TO ONE ARC_1 = ARC_LOOP(NET,DEST,1)ARC_2 = ARC_LOOP(NET,DEST,2)

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE SHR(NET,ARC_1,MODYR-1) = 1.0 ELSE SHRSUM = 0.0 DO A=ARC_1,ARC_2 SHRSUM = SHRSUM + SHR(NET,A,MODYR-1) ENDDO DO A = ARC_1,ARC_2 SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM ENDDO ENDIF ENDDO

! ADJUSTMENT IF ANGTS OR MACKENZIE DELTA COME ON

IF (CHQAK_ALB .GT. 0.0000001) THEN TOTFLW = 0.0 DO I=4,NXMAPUS SRC = CAN_XMAPUS(I,2) DEST = CAN_XMAPUS(I,1) A = NODE_2ARC(SRC,DEST) TOTFLW = TOTFLW + FLOW(NET,A) ENDDO

! 80 PERCENT INITIAL US VS CANADA DISPLACEMENT ! EM4 TRACK -- keep here

FLDEL16 = (FLOW(NET,NODE_2ARC(16,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00 FLDEL17 = (FLOW(NET,NODE_2ARC(17,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00 FLDEL18 = (FLOW(NET,NODE_2ARC(18,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00 FLDEL19 = (FLOW(NET,NODE_2ARC(19,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00

DEST = 4 ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) TOTFLW = 0.0 SHRSUM = 0.0 DO A=ARC_1,ARC_2 SRC = ARC_2NODE(A,1) TOTFLW = TOTFLW + FLOW(NET,A) IF (SRC.NE.16 .AND. SRC.NE.17) SHRSUM = SHRSUM + SHR(NET,A,MODYR-1) ENDDO A16 = NODE_2ARC(16,4) SHR(NET,A16,MODYR-1) = ( FLOW(NET,A16) + FLDEL16) / TOTFLW SHR(NET,A16,MODYR-1) = AMIN1(SHR(NET,A16,MODYR-1),1.0) A17 = NODE_2ARC(17,4) SHR(NET,A17,MODYR-1) = ( FLOW(NET,A17) + FLDEL17) / TOTFLW SHR(NET,A17,MODYR-1) = AMIN1(SHR(NET,A17,MODYR-1),1.0) SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1) IF (SHR1617.GT.1.0) THEN SHR(NET,A16,MODYR-1) = SHR(NET,A16,MODYR-1) / SHR1617 SHR(NET,A17,MODYR-1) = SHR(NET,A17,MODYR-1) / SHR1617 SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1) ENDIF DO A=ARC_1,ARC_2 IF (A.NE.A16 .AND. A.NE.A17) THEN SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR1617) / SHRSUM ENDIF ENDDO

DEST = 12 ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) TOTFLW = 0.0 SHRSUM = 0.0 DO A=ARC_1,ARC_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,12) ! INITIAL ASSUME 60 PERCENT ANGTS FLOW THRU FR 9 TO 12 ! EM4 TRACK -- keep here

SHR(NET,A9,MODYR-1) = ( FLOW(NET,A9) + ((FLDEL18+FLDEL19)*1.00) ) / TOTFLW SHR(NET,A9,MODYR-1) = AMIN1(SHR(NET,A9,MODYR-1),1.0) DO A=ARC_1,ARC_2 IF (A.NE.A9) THEN SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR(NET,A9,MODYR-1)) / SHRSUM ENDIF ENDDO

ENDIF ENDDO

! ADJUST LAST YEAR'S SHARES IF EXPECTED PRODUCTION BECOMES POSITIVE OR CHANGES SIGNIFICANTLY

DO SRG =1,NSUPSUB+NOCSREG IF (SRG.LE.NSUPSUB) THEN PRDEXP = oOGRESNGON(SRG,CURIYR) * oOGPRRNGON(SRG,CURIYR) ! "Z" ARRAYS NOT SET YET PRDEXPLAG = oOGRESNGON(SRG,CURIYR-1) * oOGPRRNGON(SRG,CURIYR-1)

IF (PRDEXPLAG.GT.0.0) THEN PRDCHG = PRDEXP / PRDEXPLAG ELSE PRDCHG = 1.0 ENDIF ELSE ORG = SRG-NSUPSUB PRDEXP = oOGRESNGOF(ORG,CURIYR) * oOGPRRNGOF(ORG,CURIYR) ! "Z" ARRAYS NOT SET YET PRDEXPLAG = oOGRESNGOF(ORG,CURIYR-1) * oOGPRRNGOF(ORG,CURIYR-1)

IF (PRDEXPLAG.GT.0.0) THEN PRDCHG = PRDEXP / PRDEXPLAG ELSE PRDCHG = 1.0 ENDIF ENDIF

IF ( (PRDEXP.GT.0.00001 .AND. PRDEXPLAG.LE.0.00001) .OR. PRDCHG.GE.1.2 .OR. PRDCHG.LE.0.8) THEN

DEST = MAP_NG(SRG) ASUP = NODE_2ARC(TNODES+SRG,DEST) DO NET=1,NETWORK TOTFLW = 0.0 ARC_1 = ARC_LOOP(NET,DEST,1) ARC_2 = ARC_LOOP(NET,DEST,2) DO A=ARC_1,ARC_2 TOTFLW = TOTFLW + FLOW(NET,A) ENDDO SHR(NET,ASUP,MODYR-1) = PRDEXP*SHRYR(NET) / TOTFLW SHRSUM = 0.0 DO A=ARC_1,ARC_2 SHRSUM = SHRSUM + SHR(NET,A,MODYR-1) ENDDO DO A=ARC_1,ARC_2 SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM ENDDO ENDDO ENDIF ENDDORETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! ! WRITE CITYGATE PRICES AND COMPONENTS TO NGODTM DEBUG FILE ! ! STATUS: COMPLETE ! ! CALLED BY: NGTDM_ITM ! ! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

SUBROUTINE NGDBUG_DTM03(YR) IMPLICIT NONE
include 'parametr' include 'ncntrl' include 'ngparinc' include 'ngitminc' include 'ngtdminc' include 'ngptmitm' include 'nghistinc' include 'ogglobal'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK INTEGER*4 N,NREG ! REGION ID INTEGER*4 YR ! HIST/FORE YR FLAG (0=HIST, 1=FORE) INTEGER*4 J,I ! REG COUNTERS INTEGER*4 TNET ! REPRESENTS ANNUAL

REAL*4 TRES_COM ! TOTAL RES+COM END_USE DEMAND REAL*4 TEND_USE ! TOTAL END_USE DEMAND REAL*4 YRSHR ! PK/OP DMD SHRS REAL*4 YRSHR_F ! PK/OP UTIL FIRM DMD SHRS REAL*4 YRSHR_I ! PK/OP UTIL INTR DMD SHRS

REAL*4 TMP_END_USE(DNODES) ! HOLDS PK END-USE DMDS REAL*4 TMP_RES_COM(DNODES) ! HOLDS PK RES+COM DMDS REAL*4 AEND_USE(DNODES) ! ANNUAL END-USE DMDS REAL*4 ACGPR_END_USE(DNODES) ! ANNUAL CITYGATE PR (WT END-USE) ! ----------

IF (NGDBGITR(1,3)) THEN WRITE(NGODTM,100) ENDIF DO NET=1,NETWORK DO N=1,DNODES

TRES_COM = 0.0 TEND_USE = 0.0 DO I=1,DSEC-1 IF (NET .EQ. PKNET) THEN YRSHR = PKSHR_DMD(I,N) ELSE YRSHR = 1.-PKSHR_DMD(I,N) ENDIF TEND_USE = TEND_USE+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N)) IF (I.EQ.1 .OR. I.EQ.2) THEN TRES_COM = TRES_COM+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N)) ENDIF ENDDO DO J=1,NNGEM-1 NREG=EMMSUB_NG(J) IF (NREG .EQ. N) THEN IF (NET .EQ. PKNET) THENYRSHR_F = PKSHR_UDMD_F(J) YRSHR_I = PKSHR_UDMD_I(J) ELSE YRSHR_F = 1. - PKSHR_UDMD_F(J) YRSHR_I = 1. - PKSHR_UDMD_I(J) ENDIF TEND_USE = TEND_USE + (YRSHR_F* ZNGUQTY_F(J)) + & (YRSHR_I* ZNGUQTY_I(J)) ENDIF ENDDO

IF (NGDBGITR(1,3)) THEN IF (YR.EQ.0) THEN ! HISTORICAL YEAR WRITE(NGODTM,110) MODYR,CURITR, NET, N, & HCGPR(NET,N,MODYR), NODE_ENDPR(NET,N), & INTRAREG_TAR(NET,N), INTRAST_TAR(N), & CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), & TEND_USE, TRES_COM ELSE ! FORECAST YEAR WRITE(NGODTM,110) MODYR,CURITR, NET, N, & CGPR(NET,N), NODE_ENDPR(NET,N), & INTRAREG_TAR(NET,N), INTRAST_TAR(N), & CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), & TEND_USE, TRES_COM ENDIF ENDIF

IF (NET .EQ. PKNET) THEN TMP_END_USE(N) = TEND_USE TMP_RES_COM(N) = TRES_COM ELSE IF (YR.EQ.0) THEN ! HISTORICAL YEAR AEND_USE(N) = TMP_END_USE(N) + TEND_USE ACGPR_END_USE(N) = ((HCGPR(PKNET,N,MODYR)*TMP_END_USE(N))+ &

(HCGPR(OPNET,N,MODYR)*TEND_USE)) / AEND_USE(N) oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM oACGPR_RESCOM(N,CURIYR) = ((HCGPR(PKNET,N,MODYR)*TMP_RES_COM(N))+ &

(HCGPR(OPNET,N,MODYR)*TRES_COM)) / oARESCOM(N,CURIYR) ELSE ! FORECAST YEAR AEND_USE(N) = TMP_END_USE(N) + TEND_USE ACGPR_END_USE(N) = ((CGPR(PKNET,N)*TMP_END_USE(N)) + &

(CGPR(OPNET,N)*TEND_USE)) / AEND_USE(N) oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM oACGPR_RESCOM(N,CURIYR) = ((CGPR(PKNET,N)*TMP_RES_COM(N)) + &

(CGPR(OPNET,N)*TRES_COM)) / oARESCOM(N,CURIYR) ENDIF AVG_CGPR(N,MODYR) = ACGPR_END_USE(N) ENDIF

ENDDO ENDDO

! PUT INTO REPORT VARIABLES NGCGPR(REG,YR), NGNODDMD(REG,YR), NGENDDMD(REG,YR) ! NOTE: 'REGIONS' 13,14,15 ARE CDs 5,8,9 (for reporting)

DO N=1,DNODES NGNODDMD(N,CURIYR) = 0.0

NGCGPR(N,CURIYR) = ACGPR_END_USE(N) NGENDDMD(N,CURIYR) = AEND_USE(N) DO NET=1,NETWORK NGNODDMD(N,CURIYR) = NGNODDMD(N,CURIYR) + & NODE_DMD(NET,N) ENDDO
IF (N .EQ. 5) THEN ! combine ngreg 5&10 into CD 5NGCGPR(DNODES+1,CURIYR) = ( (ACGPR_END_USE(10)*AEND_USE(10)) + & (ACGPR_END_USE(N) *AEND_USE(N))) / & (AEND_USE(10) + AEND_USE(N)) NGENDDMD(DNODES+1,CURIYR) = AEND_USE(10) + AEND_USE(N) NGNODDMD(DNODES+1,CURIYR) = 0.0 DO NET=1,NETWORK NGNODDMD(DNODES+1,CURIYR) = NGNODDMD(DNODES+1,CURIYR) + & NODE_DMD(NET,10) + NODE_DMD(NET,N) ENDDO ELSE IF (N .EQ. 8) THEN ! combine ngreg 8&11 into CD 8 NGCGPR(DNODES+2,CURIYR) = ( (ACGPR_END_USE(11)*AEND_USE(11)) + & (ACGPR_END_USE(N) *AEND_USE(N))) / & (AEND_USE(11) + AEND_USE(N)) NGENDDMD(DNODES+2,CURIYR) = AEND_USE(11) + AEND_USE(N) NGNODDMD(DNODES+2,CURIYR) = 0.0 DO NET=1,NETWORK NGNODDMD(DNODES+2,CURIYR) = NGNODDMD(DNODES+2,CURIYR) + & NODE_DMD(NET,11) + NODE_DMD(NET,N) ENDDO ELSE IF (N .EQ. 9) THEN ! combine ngreg 9&12 into CD 9 NGCGPR(DNODES+3,CURIYR) = ( (ACGPR_END_USE(12)*AEND_USE(12)) + & (ACGPR_END_USE(N) *AEND_USE(N))) / & (AEND_USE(12) + AEND_USE(N)) NGENDDMD(DNODES+3,CURIYR) = AEND_USE(12) + AEND_USE(N) NGNODDMD(DNODES+3,CURIYR) = 0.0 DO NET=1,NETWORK NGNODDMD(DNODES+3,CURIYR) = NGNODDMD(DNODES+3,CURIYR) + & NODE_DMD(NET,12) + NODE_DMD(NET,N) ENDDO ENDIF ENDDO

IF (NGDBGITR(1,3)) THEN WRITE(NGODTM,120) DO N=1,DNODES TNET = 0 WRITE(NGODTM,130) MODYR,CURITR, TNET, N, & ACGPR_END_USE(N), AEND_USE(N), & oACGPR_RESCOM(N,CURIYR), oARESCOM(N,CURIYR) ENDDO ENDIF

100 FORMAT(1X,'DTM03: YEAR ITR NET NOD CGPRICE = NODEPR + ', & 'INTRAREG + INTRAST + CGBENCH INTRA_FLO END_USE_DMD', & ' RES+COM_DMD') 110 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3, & F10.3,3F14.1)

120 FORMAT(1X,'DTM03: YEAR ITR NET NOD CGPR_END QEND_USE ', & ' CGPR_R+C QRES+COM') 130 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3)

RETURN END