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

!

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

!

! NEW INTERSTATE TRANSMISSION MODULE (ITM) FOR THE NGTDM

!

! 01/02/97 SPLIT FROM PREPROCESSING PORTION, PUT INTO NGTDM

!

! STATUS:

!

! CALLED BY: NGMAIN

!

! CALLS: NGITM_PRE ! PREPROCESSOR

! NGSET_NODEDMD ! SET NET DMDS

! NGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS

! NGSET_SUPPR ! SET SUPPLY PR USING CURVE

! NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

! NGSET_STORPR ! SET STORAGE PRICE

! NGUP_TREE(NET) ! SET NODE PRICE

! NGSET_SECPR ! SET END-USE SECTOR PRICES

! NGCHK_CONVNG ! CHECK CONVERGENCE UP/DOWN TREE

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

! NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ

! NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

!

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

!

SUBROUTINE NGTDM_ITM

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

include 'nghistinc'

include 'ngptmitm'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 DEST,N ! REGION ID

INTEGER*4 A ! ARC ID

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 SRC ! NODE ID

INTEGER*4 L,STID ! COUNTER

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

!!! TEMP: SET PIPELINE UTILIZATIONS TO 1 AFTER HIST YEARS

IF (MODYR .GT. NOBLDYR) THEN !utz

DO A=1,NARCS !utz

SRC = ARC_2NODE(A,1) !utz

!utz

IF (SRC .LE. TNODES) THEN !utz

PKUTZ(A) = 1.0 !utz

OPUTZ(A) = 1.0 !utz

ENDIF !utz

ENDDO !utz

ENDIF !utz

CALL NGITM_PRE ! PREPROCESSING FOR THE ITM

! - SET CONST DMD

! - SET MAX CAPACITY

! IF (CURITR.EQ.1 .AND. MODYR.GE.2011 .AND. MODYR.LE.2018) THEN

! PARM_SUPELAS(1) = PARM_SUPELAS(1) + 0.0375
! PARM_SUPELAS(2) = PARM_SUPELAS(2) + 0.03125

! PARM_SUPELAS(3) = PARM_SUPELAS(3) + 0.025

! PARM_SUPELAS(4) = PARM_SUPELAS(4) + 0.01875

! PARM_SUPELAS(5) = PARM_SUPELAS(5) + 0.0

! ENDIF

! SET ARC_SHRPR TO T-1 LEVEL EACH NEMS ITERATION

DO NET=1,NETWORK

DO A=1,NARCS

ARC_SHRPR(NET,A) = ARC_PREV_SHRPR(NET,A)

ENDDO

ENDDO

! SET RBKSTOP_PADJ TO 0.0 1ST NEMS ITR

DO NET=1,NETWORK

DO DEST=1,TNODES

RBKSTOP_FLG(NET,DEST) = -1

BKSTOP_PADJ(NET,DEST) = 0.1

!EM4 IF (CURITR .EQ. 1) THEN

RBKSTOP_PADJ(NET,DEST) = 0.0

!CCC RBKSTOP_PADJ(NET,DEST) = 0.5 * RBKSTOP_PADJ(NET,DEST)

!EM4 ENDIF

ENDDO

ENDDO

! CYCLE UP & DOWN NETWORK TREE

CYCLE = 1 ! BEGIN CYCLE AT 1

CNVGFLG = 0

DO WHILE ((CNVGFLG .EQ. 0) .AND. (CYCLE .LE. MAXCYCLE))

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

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN

IF ((CYCLE .EQ. 1) .AND. (CURITR .EQ. 1)) THEN

CALL NGHIST_DISCR

ENDIF

! ADD HISTORICAL NET INJECTIONS TO NODE_DMD ON OP NETWORK

DO L=1,NPROC

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

! ADD NET INJECTIONS TO OFFPEAK DMDS

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .GT. (TNODES+SNODES)) THEN

STID = SRC - (TNODES+SNODES)

NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + &

HNETINJ(STID,MODYR) - HNETWTH(STID,MODYR)

ENDIF

ENDDO

ENDDO

ENDIF

DO NET=1,NETWORK

CALL NGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS

ENDDO

! IF (MODYR .LE. LHISYR) THEN

! CALL HNGSET_SUPPR ! SET HIST SUPPLY, FLOWS BY SEASON

! else

! CALL NGCHK_CONVNG ! CHECK UP/DOWN TREE CONV USING SUP PROD

! endif

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

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN

IF (CNVGFLG .EQ. 1) THEN

CALL HNGSET_SUPPR ! SET HIST SUPPLY, FLOWS BY SEASON

ENDIF

ENDIF

CALL NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

DO NET=NETWORK,1,-1 ! SET NODE & STORAGE PR

IF (NET .EQ. PKNET) CALL NGSET_STORPR

CALL NGUP_TREE(NET)

ENDDO

CALL NGSET_INTRAFLO ! SET INTRAREGIONAL FLOWS & CAPACITIES

! (AND FOR LHISYR,

! SET CITYGATE PRICES AND BENCHMARK FAC)

CALL NGSET_SECPR ! SET END-USE SECTOR PRICES

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

! DEBUG REPORTS

IF (NGDBGITR(4,2)) THEN

CALL NGITM_DEBUG2(NGOTREE)

CALL NGITM_DEBUG3(NGOTREE)

ENDIF

IF (NGDBGITR(4,1)) THEN

CALL NGITM_DEBUG7(NGOBAL)

ENDIF

CYCLE = CYCLE+1

ENDDO

IF (CNVGFLG .EQ. 0) THEN

WRITE(NGOERR,*) 'NOT CONVERGED ON CYCLE= ',MAXCYCLE, &

' ITR= ',CURITR,' YEAR= ',MODYR, ' ! ATTN4'

ENDIF

CALL NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ

CALL NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

IF (NGDBGITR(4,11)) THEN

CALL NGITM_DEBUG7(NGOBAL)

ENDIF

IF (NGDBGITR(4,12)) THEN

CALL NGITM_DEBUG2(NGOTREE)

CALL NGITM_DEBUG3(NGOTREE)

ENDIF

CALL NGDBUG_DTM03(1)

RETURN

END

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

!

! SET NET NODE DEMANDS USING END-USE AND CONST DEMANDS

! NODE_DMD

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

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

SUBROUTINE NGSET_NODEDMD

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'nghistinc'

include 'ogglobal'

INTEGER*4 A,J,L,I ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 ST ! STORAGE NODE ID (1-14)

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 N ! NODE ID

INTEGER*4 SEC ! SECTOR ID (1-5)

REAL*4 PKQTY_F ! PLACEHOLDER FOR PF QTY

REAL*4 OPQTY_F ! PLACEHOLDER FOR OF QTY

REAL*4 PKQTY_I ! PLACEHOLDER FOR PI QTY

REAL*4 OPQTY_I ! PLACEHOLDER FOR OI QTY

REAL*4 ADJ ! VOLUME TO ADJUST NEW ENGLAND IMPORTS IF NET DEMAND FALLS 

TOO LOW

REAL*4 MINDMD ! MINIMUM NET NODE DEMAND IN NEW ENGLAND

INTEGER*4 V, W, C

LOGICAL TMPSET/.TRUE./

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

IF (TMPSET) THEN

IF (MODYR .GT. LHISYR) THEN

TMPSET = .FALSE.

ENDIF

PERMTH(PKNET) = 1./4.

PERMTH(OPNET) = 1./8.

DO C=1,NETWORK

DO W=1,TNODES

SPERMTH(C,W) = 0.30

IF (C.EQ.1) THEN

SPERMTH(C,W) = HSPERJAN(W,LHISYR+1)

ENDIF

ENDDO

DO W=1,SNODES

IF(SUPARRAY(W).EQ.1) THEN

PPERMTH(C,W) = PERMTH(C)

IF (C.EQ.1 .AND. SUPTYPE(W).LE.2) THEN

PPERMTH(C,W) = HPPERJAN(W,LHISYR+1)

ENDIF

IF(W.GE.FSRGN(1).AND.W.LT.FSRGN(3)) PPERMTH(C,W+FSRGN(7)-1)=PPERMTH(C,W) 

!AD GAS

ENDIF

ENDDO

DO W=1,NNGEM-1

UCPERMTH(C,W) = PERMTH(C)

IF (C.EQ.1) THEN

UCPERMTH(C,W) = HUCPERJAN(W,LHISYR+1)

ENDIF

!xxx UCPERMTH(C,W) = .30

ENDDO

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

NCPERMTH(C,W,1) = .30

NCPERMTH(C,W,2) = .28

NCPERMTH(C,W,3) = .26

NCPERMTH(C,W,4) = PERMTH(C)

!xxx NCPERMTH(C,W,1) = PERMTH(C)

!xxx NCPERMTH(C,W,2) = PERMTH(C)

!xxx NCPERMTH(C,W,3) = PERMTH(C)

!xxx NCPERMTH(C,W,4) = PERMTH(C)

IF (C.EQ.1) THEN

DO V=1,DSEC-1

NCPERMTH(C,W,V) = HCPERJAN(W,V,LHISYR+1)

ENDDO

ENDIF

ENDDO

ENDDO

ENDIF

! RESET NODE DEMANDS: CONST DMDS/SUP

DO NET=1,NETWORK

DO N=1,TNODES+SNODES+STNODES

NODE_DMD(NET,N) = 0.0

ENDDO

DO N=1,TNODES

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

NODE_DMD(NET,N) = NODE_CDMD(NET,N)

! peak month

MTH_CONS(NET,N) = MTH_CDMD(NET,N)

ENDDO

ENDDO

IF (((CYCLE .EQ. 1) .OR. (CYCLE.EQ.0)) .AND. &

(CURITR .EQ. 1)) THEN

! WRITE (NGODTM,*) " YR IT CY RG PEAK OFFPEAK",

! * " <--NODE_CDMD"

! DO N=1,TNODES

! WRITE (NGODTM,110) MODYR,CURITR,CYCLE,N,

! * (NODE_CDMD(NET,N),NET=1,NETWORK)

! ENDDO

WRITE (NGODTM,*) " YR IT CY RG RES COM", &

" IND TRN <--ZNGQTY_F"

DO N=1,DNODES

WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, &

(ZNGQTY_F(SEC,N),SEC=1,DSEC-1)

ENDDO

WRITE (NGODTM,*) " YR IT CY RG RES COM", &

" IND TRN <--ZNGQTY_I"

DO N=1,DNODES

WRITE (NGODTM,111) MODYR,CURITR,CYCLE,N, &

(ZNGQTY_I(SEC,N),SEC=1,DSEC-1)

ENDDO

WRITE (NGODTM,*) " YR IT CY RG U_FIRM U_INTR", &

" <--ZNGUQTY_*"

DO J=1,NNGEM-1

WRITE (NGODTM,111) MODYR,CURITR,CYCLE,J, &

ZNGUQTY_F(J),ZNGUQTY_I(J)

ENDDO

ENDIF

110 FORMAT(1X,I4,I3,I3,I3,2(F10.3))

111 FORMAT(1X,I4,I3,I3,I3,4(F10.3))

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

DO N=1,DNODES

DO SEC=1,DSEC-1

PKQTY_F = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N)

OPQTY_F = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_F(SEC,N)

PKQTY_I = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N)

OPQTY_I = (1.-PKSHR_DMD(SEC,N)) * ZNGQTY_I(SEC,N)

NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + &

PKQTY_F + PKQTY_I

NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + &

OPQTY_F + OPQTY_I

NGQTY_SF(PKNET,SEC,N) = PKQTY_F

NGQTY_SF(OPNET,SEC,N) = OPQTY_F

NGQTY_SI(PKNET,SEC,N) = PKQTY_I

NGQTY_SI(OPNET,SEC,N) = OPQTY_I

! peak month

MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + &

((PKQTY_F + PKQTY_I) * NCPERMTH(PKNET,N,SEC))

MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + &

((OPQTY_F + OPQTY_I) * NCPERMTH(OPNET,N,SEC))

ENDDO

ENDDO

! UTILITY

DO J=1,NNGEM-1

N = EMMSUB_NG(J)

PKQTY_F = PKSHR_UDMD_F(J) * ZNGUQTY_F(J)

OPQTY_F = (1.-PKSHR_UDMD_F(J)) * ZNGUQTY_F(J)

PKQTY_I = PKSHR_UDMD_I(J) * ZNGUQTY_I(J)

OPQTY_I = (1.-PKSHR_UDMD_I(J)) * ZNGUQTY_I(J)

NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + &

PKQTY_F + PKQTY_I

NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + &

OPQTY_F + OPQTY_I

NGUQTY_SF(PKNET,J) = PKQTY_F

NGUQTY_SF(OPNET,J) = OPQTY_F

NGUQTY_SI(PKNET,J) = PKQTY_I

NGUQTY_SI(OPNET,J) = OPQTY_I

! peak month

MTH_CONS(PKNET,N) = MTH_CONS(PKNET,N) + &

((PKQTY_F + PKQTY_I) * UCPERMTH(PKNET,J))

MTH_CONS(OPNET,N) = MTH_CONS(OPNET,N) + &

((OPQTY_F + OPQTY_I) * UCPERMTH(OPNET,J))

ENDDO

! RESET NODE DEMANDS: NEW END-USE DMDS

! DO N=1,DNODES

! DO SEC=1,DSEC-1

! NGQTY_SF(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_F(SEC,N)

! NGQTY_SF(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) *

! * ZNGQTY_F(SEC,N)

! NGQTY_SI(PKNET,SEC,N) = PKSHR_DMD(SEC,N) * ZNGQTY_I(SEC,N)

! NGQTY_SI(OPNET,SEC,N) = (1.-PKSHR_DMD(SEC,N)) *

! * ZNGQTY_I(SEC,N)

! NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) +

! * NGQTY_SF(PKNET,SEC,N) + NGQTY_SI(PKNET,SEC,N)

! NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) +

! * NGQTY_SF(OPNET,SEC,N) + NGQTY_SI(OPNET,SEC,N)

! ENDDO

! ENDDO

! NOTE: THE FOLLOWING IS DONE BECAUSE NGUQTY_SF AND _SI ARE NEEDED

! IN SUBROUTINE NGSET_SECPR TO DETERMINE END-USE UTILITY PR

! DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16
! NGUQTY_SF(PKNET,J) = PKSHR_UDMD_F(J) * NGUQTY_F(J)

! NGUQTY_SF(OPNET,J) = (1.-PKSHR_UDMD_F(J)) *

! * NGUQTY_F(J)

! NGUQTY_SI(PKNET,J) = PKSHR_UDMD_I(J) * NGUQTY_I(J)

! NGUQTY_SI(OPNET,J) = (1.-PKSHR_UDMD_I(J)) *

! * NGUQTY_I(J)

! ENDDO

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

FIXED LNG

I = 1 ! FOR NEW ENGLAND, CHECK IF NODE_DMD TOO LOW

N = MAPLNG_NG(I)

ADJ = 0.0

MINDMD = 50.0

IF (NODE_DMD(PKNET,N).LT.MINDMD) ADJ = ADJ + (MINDMD - NODE_DMD(PKNET,N)) / 

PKSHR_ILNG(I)

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

(1.-PKSHR_ILNG(I))

IF (ADJ.GT.oOGQNGIMP(14+I,CURIYR)) ADJ = oOGQNGIMP(14+I,CURIYR)

NODE_DMD(PKNET,N) = NODE_DMD(PKNET,N) + (ADJ * PKSHR_ILNG(I))

NODE_DMD(OPNET,N) = NODE_DMD(OPNET,N) + (ADJ * (1.-PKSHR_ILNG(I)))

oOGQNGIMP(14+I,CURIYR) = oOGQNGIMP(14+I,CURIYR) - ADJ

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

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

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (PKSHR_ILNG(I) * ADJ * 0.25) !1/4

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

ENDIF

RETURN

END

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

!

! MOVE DOWN TREE,

! DETERMINE SUPPLY SHARES AND FLOWS,

! ACCUMULATE DEMANDS AT SOURCE NODES

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! CALLS TO: NGSHR_CALC

! NGSHR_MAXCHK

!

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

SUBROUTINE NGDOWN_TREE(NET)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngsteoinc'

include 'nghistinc'

include 'ngcdmdinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 L,N,A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 PFUEL_FLG(ARCS) ! FLAG INDICATING PIPE FUEL CONSUMP
REAL*4 TFLOW ! TOTAL FLOW ALONG PIPE ARCS INTO A NODE

REAL*4 NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC

REAL*4 GAMMATMP ! TMP PLACEHOLDER FOR GAMMAFAC FOR OPT 5

LOGICAL ONCE/.TRUE./ ! DO ONLY ONCE

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

IF (ONCE) THEN

ONCE = .FALSE.

GAMMATMP = GAMMAFAC ! temp

ENDIF

! INITIALIZE BKSTOP TO ZERO BEFORE ALLOCATING SHARES

DO N=1,TNODES

BKSTOP(NET,N) = 0.0

ENDDO

!CCC BKSTOP_FLG = 0

! LOOP OVER PROCESSING NODES GOING DOWN NETWORK

DO L=1,NPROC ! NUMBER OF PROCESSING NODES

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! DEFINE PIPE FUEL CONSUMPTION AND ADD TO NET DMD (NODE_DMD)

! PFUEL_FAC = PF / NODE_DMD(W/O PF)

IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN

IF ((NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)).NE.0.0) &

HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / &

(NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST))

ELSE

IF (NODE_DMD(NET,DEST) .LE. 0.0) THEN

IF (DEST.LE.DNODES) DISCR(NET,DEST,MODYR) = DISCR(NET,DEST,MODYR) - 

NODE_DMD(NET,DEST) + 1.

!YD1? NODE_DMD(NET,DEST) = 1. !YD1: THIS CONDITION CHANGES ZERO DMD AT 

LNG NODES MAKING BKSTOP>0

ENDIF

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

(NODE_DMD(NET,DEST)+FIXSUPIP(NET,DEST)) * FE_PFUEL_FAC(MODYR)

PFUEL(NET,DEST) = AMIN1(PFUEL(NET,DEST),0.15*NODE_DMD(NET,DEST) )

ENDIF

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

! TEMPCODE: 09/03/97

INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST)

! TEMPCODE: 09/03/97

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

IF (SHR_OPT .EQ. 1) THEN ! original method

CALL NGSHR_CALC(DEST,NET)

ELSE IF (SHR_OPT .EQ. 2) THEN ! func (added net dmd)

if (modyr .le. lhisyr) then ! temp

GAMMAFAC = 1.0 ! temp

CALL NGSHR_CALC(DEST,NET) ! temp

else ! temp

GAMMAFAC = GAMMATMP ! temp

CALL Z2NGSHR_CALC(DEST,NET)

endif ! temp

ELSE IF (SHR_OPT .EQ. 3) THEN ! func (added net dmd): not good

if (modyr .le. lhisyr) then ! temp
CALL NGSHR_CALC(DEST,NET) ! temp

else ! temp

CALL Z3NGSHR_CALC(DEST,NET)

endif ! temp

ELSE IF (SHR_OPT .EQ. 4) THEN ! func (added rem cap)

if (modyr .le. lhisyr) then ! temp

CALL NGSHR_CALC(DEST,NET) ! temp

else ! temp

CALL Z4NGSHR_CALC(DEST,NET)

endif ! temp

ELSE IF (SHR_OPT .EQ. 5) THEN ! func (added rem cap)

if (modyr .le. lhisyr) then ! temp

GAMMAFAC = 1.0 ! temp

CALL NGSHR_CALC(DEST,NET) ! temp

else ! temp

GAMMAFAC = GAMMATMP ! temp

CALL Z5NGSHR_CALC(DEST,NET)

endif ! temp

ELSE IF (SHR_OPT .EQ. 6) THEN ! func (added net dmd)

if (modyr .le. lhisyr) then ! temp

CALL NGSHR_CALC(DEST,NET) ! temp

else ! temp

CALL Z6NGSHR_CALC(DEST,NET)

endif ! temp

ENDIF

IF ((EHISYR .EQ. LHISYR) .AND. (MODYR .LE. LHISYR)) THEN

CALL NGSHR_LHISYR(DEST,NET)

ELSE

IF ((NET .EQ. PKNET) .AND. (MODYR.GT.NOBLDYR)) THEN !utz

MTH_CONS(NET,DEST) = MTH_CONS(NET,DEST) + & !utz

(PERMTH(NET) * PFUEL(NET,DEST)) !utz

CALL NGSHR_MAXCHK(DEST,NET) !utz

CALL NGSHR_MTHCHK(DEST,NET) !utz

ELSE !utz

CALL NGSHR_MAXCHK(DEST,NET)

ENDIF !utz

ENDIF

! SET ARC FLOWS AND ADD TO TOTAL DEMANDS AT SOURCE NODES.

! ALSO, ADD STORAGE SUPPLY IN PK TO NODE DMD IN OP.

! NOTE: NODE_DMD(1,STORAGE) ONLY USED TO TRACK STORAGE QTY.

TFLOW = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

FLOW(NET,A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST)

NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)

IF ((NET.EQ.PKNET) .AND. (SRC.GT.(TNODES+SNODES))) THEN

NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + FLOW(NET,A)

ENDIF

! SET REMIANING FLOW

IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)-.0001) THEN

FLOW_REM(NET,A) = 0.0 ! REMAINING FLOW = 0

ELSE

FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A)

ENDIF

IF (SRC .LE. TNODES) THEN

PFUEL_FLG(A) = 1 ! PIPEFUEL CONS ON THIS ARC

TFLOW = TFLOW + FLOW(NET,A)

ELSE

PFUEL_FLG(A) = 0

ENDIF

ENDDO
! SET PIPEFUEL ALONG PIPE ARC ONLY

DO A=ARC_1,ARC_2

IF (PFUEL_FLG(A) .EQ. 1 .AND. TFLOW.GT.0.000001) THEN

ARC_PFUEL(NET,A)= (PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST))* &

(FLOW(NET,A)/TFLOW)

ELSE

ARC_PFUEL(NET,A) = 0.0

ENDIF

ENDDO

ENDDO

RETURN

END

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

!

! SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS

!

! STATUS: UNDER CONSTRUCTION

!

! CALLED BY: NGDOWN_TREE

!

! FUNCTIONS USED:

!

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

SUBROUTINE NGSHR_LHISYR(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'nghistinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A,I ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES

INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)

INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

INTEGER*4 CNBRD ! AID IM MAPPING FR ARC TO BORDER XING

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR

REAL*4 SUMMAX ! TOTAL SHARES AT MAX SHR

REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION

REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

REAL*4 TMPFLO ! HOLDS PIPE FLOW TEMPORARILY

REAL*4 SUMFAC ! FACTOR (1,0) TO SET SHR=0 IF NEEDED

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! SET HISTORICAL SUPPLY SHR AND MAX SHR

TMAXFLO = 0.0

CHK = 0

! NETDMD = NODE_DMD(NET,DEST)

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

MAXFLG(A) = 0

OLDFLG(A) = 0

!!!! IF ((SRC .GT. TNODES) .AND. (SRC .LE. TNODES+SNODES)) THEN ! SUPPLY

!!!x IF (SRC .GT. TNODES) THEN ! SUPPLY & STORAGE

!!!z IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2)) THEN ! SUPPLY&STR

IF ((SRC.GT.TNODES) .AND. (SRC.LE.TNODES+SNODES+STNODES-2) .AND. & !YD1: 

CHANGE IF OTHER SUPPLY BECOMES VARIABLE!!!!

(SRC.NE.TNODES+SNODES-lSNODES-3)) THEN ! SUP, STR, NOT CAN SUP

MAXFLO(NET,A) = FLOW(NET,A)

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK?

ENDIF

SHR(NET,A,MODYR) = SHRMAX(A)

TMAXFLO = TMAXFLO + MAXFLO(NET,A)

! NETDMD = NETDMD - FLOW(NET,A)

! OLDFLG(A) = 1

ELSEIF (SRC.GT.DNODES .AND. SRC.LE.TNODES-LNGNODES-2 .AND. ARC_1.NE.ARC_2) THEN

CNBRD = 0

DO I=1,NXMAPUS

IF (CAN_XMAPUS(I,2).EQ.SRC .AND. CAN_XMAPUS(I,1).EQ.DEST) CNBRD = I

ENDDO

IF (CNBRD.EQ.0) WRITE(6,*) ' NGCHECK MAP NGSHR_LHISYR ',SRC,DEST

IF (NET.EQ.PKNET) THEN

MAXFLO(NET,A) = HAFLOW(A,LHISYR) * HPKSHR_ICAN(LHISYR)

ELSE

MAXFLO(NET,A) = HAFLOW(A,LHISYR) * (1.-HPKSHR_ICAN(LHISYR))

ENDIF

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK?

ENDIF

SHR(NET,A,MODYR) = SHRMAX(A)

TMAXFLO = TMAXFLO + MAXFLO(NET,A)

ELSE ! PIPELINE ARCS !YD1LNG: 

PROCESS LNG NODES DIFFERENTLY

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION

IF (ARC_1 .NE. ARC_2) THEN

TMPFLO = AMIN1((MAXFLO(NET,A)*.99999), &

(SHR(NET,A,MODYR)*NODE_DMD(NET,DEST)))

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHR(NET,A,MODYR) = TMPFLO / NODE_DMD(NET,DEST)

ELSE

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) ! temp, 10-26-05 ?????? OK?

ENDIF

ENDIF

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHRMAX(A) = SHR(NET,A,MODYR-1) * 1.2 ! temp, 10-26-05 ?????? OK?

ENDIF

TMAXFLO = TMAXFLO + MAXFLO(NET,A)

! OLDFLG(A) = 0

ENDIF

ENDDO

! check this

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

CHNG = 1

DO WHILE (CHNG .EQ. 1)

CHK = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS
IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN

SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW

MAXFLG(A) = 1

IF (MAXFLG(A) .NE. OLDFLG(A)) THEN

CHK = 1

OLDFLG(A) = MAXFLG(A)

ENDIF

ENDIF

ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS

SUMMAX = 0.0

SUMREM = 0.0

SUMSHR = 0.0

CNT0 = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

CNT0 = CNT0 + 1

SUMSHR = SUMSHR + SHR(NET,A,MODYR)

ELSE

SUMMAX = SUMMAX + SHR(NET,A,MODYR)

ENDIF

ENDDO

IF ((SUMMAX .GT. 1.0) .AND. (SUMSHR.GE. 0.0)) THEN

SUMREM = 0.0

SUMFAC = 0.0

ELSE

IF ((SUMSHR+SUMMAX) .GT. 1.0) THEN

SUMREM = 0.0

SUMFAC = (1.-SUMMAX) / SUMSHR

ELSE

SUMREM = 1. - (SUMSHR+SUMMAX)

SUMFAC = 1.0

ENDIF

ENDIF

! DISTRIBUTE OVER UNCONSTR ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

IF (SUMSHR .GT. 0.0) THEN

SHR(NET,A,MODYR) = (SUMFAC + (SUMREM/SUMSHR)) * &

SHR(NET,A,MODYR)

ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN

SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)

ENDIF

ENDIF

ENDDO

ELSE

CHNG = 0

ENDIF

ENDDO

ELSE ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO

!CCC BKSTOP_FLG = 1

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = SHRMAX(A)

ENDDO

WRITE(NGOERR,100) & ! ATTN

MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), &

TMAXFLO, RBKSTOP_PADJ(NET,DEST)

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

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

RETURN

END

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

!

! SET REMAINING FLOW ALONG ARC

!

! STATUS: COMPLETE

!

! CALLED BY: NGDOWN_TREE

! HNGDOWN_TREE

!

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

REAL FUNCTION NGSET_FLOWREM(NET,A)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A ! COUNTERS

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

REAL*4 FAC ! PK/OP FACTOR

! ----------

SRC = ARC_2NODE(A,1)

IF (NET .EQ. PKNET) THEN

! REMAINING FLOW IN PK BASED ON CUR CAP

IF (SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARC

FAC = PKUTZ(A)

ELSE ! PIPELINE OR SUPPLY ARC

FAC = PKSHR_YR * PKUTZ(A)

ENDIF

NGSET_FLOWREM = AMAX1( 0., FAC*CURPCAP(A,MODYR) - FLOW(NET,A))

ELSE

! REMAINING FLOW IN OP BASED ON MAX OP CAP

NGSET_FLOWREM = AMAX1( 0., MAXFLO(NET,A) - FLOW(NET,A))

ENDIF

RETURN

END

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

!

! SET SECONDARY FLOWS OUT OF MIDDLE ATLANTIC

!

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

SUBROUTINE NGSECFLOW2

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'ngsteoinc'

include 'nghistinc'
include 'ogglobal'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DST(3) ! THREE NODES WITH SEC FLOWS OUT OF SRC(3)

INTEGER*4 SRC(4) ! THREE NODES WITH SEC FLOWS INTO DST(3)

INTEGER*4 DEST ! SPECIFIC DESTINATION NODE

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 I,J ! COUNTERS

INTEGER*4 ICNT ! KEEP TRACK OF NUMBER OF ARCS GOING INTO DST

INTEGER*4 ARCPRM ! ARC NUMBER FOR PRIMARY ARC INTO DST

INTEGER*4 ARCPRM2 ! ARC NUMBER FOR PRIMARY ARC ALONG SEC ARC INTO DST

INTEGER*4 ARCSEC ! ARC NUMBER FOR SECONDARY ARC OUT OF DST

INTEGER*4 ARCSEC2 ! ARC NUMBER FOR SECOND SECONDARY ARC OUT OF DST

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SHRLAG(10) ! LAST YEAR'S SHARES BASED ON FLWLAG

REAL*4 SHRTST(10) ! THIS YEAR'S SHARES IF KEY SEC FLOW INCLUDED

REAL*4 REV_ARC_SHRPR ! SHARE PRICE ALONG REVERSE FLOW ARC

REAL*4 REV_ARC_SHRPR2 ! SHARE PRICE ALONG SECOND REVERSE FLOW INTO CANADA

REAL*4 FLWTOT ! TOTAL FLOW LAST ITERATION INTO NEW DEST ARC, INCL FROM 2

REAL*4 SHRSUM ! SUM OF NONNORMALIZED SHARES INTO NEW DEST ARC, INCLU 

FROM 2

REAL*4 REV_FLOW(NETWORK,4) ! FINAL FLOW BY NETWORK ON REVERSE FLOW ARC INTO 

DEST J

REAL*4 FLWLAG(10,NETWORK,3) ! FLOW INTO DEST LAST YEAR, INCL KEY SEC FLOW, 10 

MAX NUMBER

REAL*4 FLWLAGTOT(NETWORK,3) ! TOTAL FLOW LAST YEAR INTO NEW DEST ARC, INCL 

FROM 2

REAL*4 FLW(4) ! HOLDING ARRAY

REAL*4 MINFLW(4) ! HOLD PRESET MINIMUM FLOW LEVELS

real*4 price(10)

DATA DST/3,5,23/

DATA SRC/2,2,14,15/

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

DO NET = 1,NETWORK

DO J=1,3

SHRTST = 0.0

SHRLAG = 0.0

IF (CURITR.EQ.1) THEN

DO I=1,10

FLWLAG(I,NET,J) = 0.0

ENDDO

ENDIF

PRICE = 0.0

DEST = DST(J)

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

N = ARC_2 - ARC_1 + 1

ARCPRM = NODE_2ARC(DEST,SRC(J))

ARCSEC = SNODE_2ARC(SRC(J),DEST)

IF (J.EQ.3) THEN

ARCPRM2 = NODE_2ARC(DEST,SRC(J+1))

ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST)

ENDIF

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

REV_ARC_SHRPR = NODE_SHRPR(NET,SRC(J))

IF (CURITR.EQ.1) THEN

FLWLAG(N+1,NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET)

FLWLAGTOT(NET,J) = SAFLOW(ARCSEC,MODYR-1) * SHRYR(NET) ! 
INITIALIZE

IF (NET.EQ.PKNET) MINFLW(J) = SAFLOW(ARCSEC,MODYR-1) ! ch to 

"-1" for conv prob, but now not used

ELSE

FLWTOT = SAFLOW(ARCSEC,MODYR) * SHRYR(NET) ! INITIALIZE

ENDIF

INVPR_SUM = (1. / REV_ARC_SHRPR) ** GAMMAFAC ! INITIALIZE

price(n+1) = rev_arc_shrpr

IF (J.EQ.3) THEN

! don't have tariff for 3->23, so make assumption

!!!!!! REV_ARC_SHRPR2 = NODE_SHRPR(NET,3) + 0.50

REV_ARC_SHRPR2 = NODE_SHRPR(NET,3)

IF (CURITR.EQ.1) THEN

FLWLAG(N+2,NET,J) = SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET)

FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + SAFLOW(ARCSEC2,MODYR-1) * SHRYR(NET) 

! INITIALIZE

IF (NET.EQ.PKNET) MINFLW(J+1) = SAFLOW(ARCSEC2,MODYR-1) ! ch to 

"-1" for conv prob, but now not used

ELSE

FLWTOT = FLWTOT + SAFLOW(ARCSEC2,MODYR) * SHRYR(NET) ! INITIALIZE

ENDIF

INVPR_SUM = INVPR_SUM + (1. / REV_ARC_SHRPR2) ** GAMMAFAC ! INITIALIZE

price(n+2) = rev_arc_shrpr2

ENDIF

ICNT = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

ICNT = ICNT + 1

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN

INVPR_SUM = INVPR_SUM + &

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

price(icnt) = arc_shrpr(net,a)

IF (CURITR.EQ.1) THEN

FLWLAG(ICNT,NET,J) = FLOW(NET,A)

FLWLAGTOT(NET,J) = FLWLAGTOT(NET,J) + FLOW(NET,A)

ELSE

FLWTOT = FLWTOT + FLOW(NET,A)

ENDIF

ELSE

WRITE(4,*) ' NGERR NEG ARC_SHRPR ', NET,DEST

ENDIF

ENDDO

DO I=1,N+1

SHRLAG(I) = FLWLAG(I,NET,J) / FLWLAGTOT(NET,J)

ENDDO

IF (J.EQ.3) THEN

SHRLAG(N+2) = FLWLAG(N+2,NET,J) / FLWLAGTOT(NET,J)

SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+2) * &

(((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM)

SHRTST(N+2)= SHRLAG(N+2) * FLOAT(N+2) * &

(((1./REV_ARC_SHRPR2)**GAMMAFAC) / INVPR_SUM)

SHRSUM = SHRTST(N+1) + SHRTST(N+2) ! INITIALIZE

ELSE

SHRTST(N+1)= SHRLAG(N+1) * FLOAT(N+1) * &

(((1./REV_ARC_SHRPR)**GAMMAFAC) / INVPR_SUM)

SHRSUM = SHRTST(N+1) ! INITIALIZE

ENDIF

ICNT=0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

ICNT = ICNT + 1

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0)) THEN

IF (J.EQ.3) THEN

SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+2) * &
(((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)

ELSE

SHRTST(ICNT) = SHRLAG(ICNT) * FLOAT(N+1) * &

(((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)

ENDIF

SHRSUM = SHRSUM + SHRTST(ICNT)

ELSE

WRITE(4,*) ' NGERR NEG INVPR_SUM ', NET,DEST

ENDIF

ENDDO

IF (CURITR.EQ.1) FLWTOT = FLWLAGTOT(NET,J)

IF (SHRSUM .GT. 0.0) THEN

REV_FLOW(NET,J) = FLWTOT * SHRTST(N+1) / SHRSUM

IF (J.EQ.3) REV_FLOW(NET,J+1) = FLWTOT * SHRTST(N+2) / SHRSUM

ELSE

REV_FLOW(NET,J) = 0.0

IF (J.EQ.3) REV_FLOW(NET,J+1) = 0.0

ENDIF

! if (fcrl.eq.1) then

! write(4,1234) modyr,curitr,net,j,(price(i),i=1,n+2)

!1234 format(1x,' JBE2 yr,itr,net,j ',4i5,10f6.2)

! write(4,1236) modyr,curitr,net,j,(shrtst(i),i=1,n+2),shrsum

!1236 format(1x, ' JBE4 yr,itr,net,j ',4i5,11f6.3)

! endif

ENDDO

ENDDO

DO J=1,3

DEST = DST(J)

ARCSEC = SNODE_2ARC(SRC(J),DEST)

ARCSEC2 = SNODE_2ARC(SRC(J+1),DEST)

FLW(J) = REV_FLOW(PKNET,J) + REV_FLOW(OPNET,J)

IF (J.EQ.3) FLW(J+1) = REV_FLOW(PKNET,J+1) + REV_FLOW(OPNET,J+1)

!!!!! SAFLOW(ARCSEC,MODYR) = AMAX1(FLW(J),MINFLW(J)) ! not 

using minflw to deal with conv prob

!!!!! IF (J.EQ.3) SAFLOW(ARCSEC2,MODYR) = AMAX1(FLW(J+1),MINFLW(J+1))

SAFLOW(ARCSEC,MODYR) = FLW(J)

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

ENDDO

ARC_1 = SNODE_2ARC(2,14)

ARC_2 = SNODE_2ARC(14,23)

IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) 

THEN

SAFLOW(ARC_2,MODYR) = CANEXP(2,MODYR) + CNFLOW_OUT(2,MODYR)

ENDIF

SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR)

SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR))

SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR))

CANEXP(2,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(2,MODYR)

oOGQNGEXP(2,CURIYR) = CANEXP(2,MODYR)

ARC_1 = SNODE_2ARC(3,15)

ARC_2 = SNODE_2ARC(15,23)

IF (BMYEAR.GT.EHISYR .AND. MODYR.GE.STEOYRS(1) .AND. MODYR.LE.STEOYRS(STEO_YEAR)) 

THEN

SAFLOW(ARC_2,MODYR) = CANEXP(3,MODYR) + CNFLOW_OUT(3,MODYR)

ENDIF

SAFLOW(ARC_1,MODYR) = SAFLOW(ARC_2,MODYR)

SACTPCAP(ARC_1) = AMAX1(SACTPCAP(ARC_1), SAFLOW(ARC_1,MODYR))

SACTPCAP(ARC_2) = AMAX1(SACTPCAP(ARC_2), SAFLOW(ARC_2,MODYR))

CANEXP(3,MODYR) = SAFLOW(ARC_1,MODYR) - CNFLOW_OUT(3,MODYR)

oOGQNGEXP(3,CURIYR) = CANEXP(3,MODYR)

! if (fcrl.eq.1) then

! IF (MODYR.EQ.LHISYR+1) WRITE(4,*) 'FLOW2 2->3 2->5 2->23 3->23'
! WRITE(4,4344) MODYR,(FLW(J),J=1,4)

!4344 FORMAT (1X, 'FLOW2 ',I5,4F8.3)

! endif

RETURN

END

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

!

! USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES

!

! STATUS: COMPLETE

!

! CALLED BY: NGDOWN_TREE

!

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

SUBROUTINE NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SHRSUM ! SUM OF NEW SHR'S--USED FOR NORMALIZING

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

INVPR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN

INVPR_SUM = INVPR_SUM + &

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

ENDIF

ENDDO

SHRSUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0)) THEN

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * &

(((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM)

SHRSUM = SHRSUM + SHR(NET,A,MODYR)

ELSE

SHR(NET,A,MODYR) = 0.0

ENDIF

ENDDO

IF (SHRSUM .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM

ENDDO

ENDIF

ENDIF
RETURN

END

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

!

! << OPTION 2 >>

! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE

!

! 8/30/99

!

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

SUBROUTINE Z2NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW

INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

INTEGER*4 LASTCYC ! TRACKS WHEN NEW CYCLE BEGINS

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING

REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD

REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD

REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1

REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE

REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO

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

!CCC IF (CYCLE .LE. 2) THEN

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

!CCC LASTCYC = CYCLE

!CCC ELSE

!CCC IF (CYCLE .NE. LASTCYC) THEN

!CCC MIN_PCTFLO = MIN_PCTFLO + ((1.-MIN_PCTFLO) / 10.)

!CCC LASTCYC = CYCLE

!CCC ENDIF

!CCC ENDIF

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

PR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))

IF (TADDDMD .LE. 0.0) THEN

MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )

TADDDMD = NODE_DMD(NET,DEST) - &

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

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

"FOR DEST, YEAR = ", DEST,MODYR

ENDIF

ENDIF

IF (TADDDMD .GE. 0.0) THEN

! NET DMD INCREASES

! DEFINE SHR TO INCREASE FLOW AS [INVP/(SUM INVP)]

DO A=ARC_1,ARC_2

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN

PR_SUM = PR_SUM + &

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

ENDIF

ENDDO

SUMSHR = 0.0

DO A=ARC_1,ARC_2

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(PR_SUM .GT. 0.0)) THEN

ADDSHR(A) = (((1./ARC_SHRPR(NET,A))**GAMMAFAC) / &

PR_SUM)

ELSE

ADDSHR(A) = 0.0

ENDIF

SUMSHR = SUMSHR + ADDSHR(A)

ENDDO

IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2

ADDSHR(A) = ADDSHR(A) / SUMSHR

ADDDMD(A) = ADDSHR(A) * TADDDMD

NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)

ENDDO

ELSE

DO A=ARC_1,ARC_2

NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO ! ???? wrong

ENDDO

ENDIF

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

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

ELSE

WRITE(NGOERR,*) " ERROR Z2NG: NEED TO CHECK CALC OF ", &

"MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &

CURITR, CYCLE

ENDIF ! end check for added net dmd > 0

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)

ENDDO

! CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)

ENDIF ! end check for single arc into node

RETURN

END

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

!

! << OPTION 3 >>

! NEW SHARING ALGORITHM BASED ON ARC PRICES (OPT 1)

! AND USING REMAINING FLOW (COMBINED OPT 2 & 4) for gammafac

!

! 8/30/99
!

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

SUBROUTINE Z3NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW

INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING

REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD

REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD

REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1

REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE

REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 PRV_REMCAP(ARCS)

REAL*4 SUM_REMCAP

REAL*4 ARC_GAMMAFAC(ARCS)

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY

REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO

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

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

PR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

! opt 4

! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)

IF (NET .EQ. PKNET) THEN

IF (SRC .GT. TNODES+SNODES) THEN ! storage

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)

ELSE IF(SRC .LE. TNODES) THEN ! pipe

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ELSE

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ENDDO
SUM_REMCAP = 0.0

DO A=ARC_1,ARC_2

IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN

PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &

ALPHAFAC

ELSE

PRV_REMCAP(A) = 0.0

ENDIF

SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)

ENDDO

INVPR_SUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A)

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(CUR_EFFCAP(NET,A).GT. 0.0)) THEN

INVPR_SUM = INVPR_SUM + &

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

ENDIF

ENDDO

SUMSHR = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0) .AND. &

(CUR_EFFCAP(NET,A).GT. 0.0)) THEN

ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) * &

(((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

ELSE

ADDSHR(A) = 0.0

ENDIF

SUMSHR = SUMSHR + ADDSHR(A)

ENDDO

! opt 4

IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

SHR(NET,A,MODYR) = ADDSHR(A) / SUMSHR

ENDDO

ELSE

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)

ENDDO

ENDIF

ENDIF ! end check for single arc into node

RETURN

END

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

!

! USE SHARING ALGORITHM option 4 TO CALCULATE SHARES ALONG ARCS INTO NODES

!

! STATUS: COMPLETE

!

! CALLED BY: NGDOWN_TREE

!

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

SUBROUTINE Z4NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'
INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ON ARC INTO DEST NODE

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SHRSUM ! SUM OF NEW SHR'S--USED FOR NORMALIZING

REAL*4 PRV_REMCAP(ARCS)

REAL*4 SUM_REMCAP

REAL*4 ARC_GAMMAFAC(ARCS)

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY

REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)

IF (NET .EQ. PKNET) THEN

IF (SRC .GT. TNODES+SNODES) THEN ! storage

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)

ELSE IF(SRC .LE. TNODES) THEN ! pipe

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ELSE

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ENDDO

SUM_REMCAP = 0.0

DO A=ARC_1,ARC_2

IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN

PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &

ALPHAFAC

ELSE

PRV_REMCAP(A) = 0.0

ENDIF

SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)

ENDDO

INVPR_SUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

ARC_GAMMAFAC(A) = 1.0 - (PRV_REMCAP(A) / SUM_REMCAP)

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN

INVPR_SUM = INVPR_SUM + &

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

ENDIF

ENDDO

SHRSUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0)) THEN

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1) * FLOAT(N) * &
(((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

SHRSUM = SHRSUM + SHR(NET,A,MODYR)

ELSE

SHR(NET,A,MODYR) = 0.0

ENDIF

ENDDO

IF (SHRSUM .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

SHR(NET,A,MODYR) = SHR(NET,A,MODYR) / SHRSUM

ENDDO

ENDIF

ENDIF

RETURN

END

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

!

! << OPTION 5 >>

! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE

! AND USING REMAINING FLOW FRACTION TIMES PRICE RATIOS

!

! 12/02/99

!

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

SUBROUTINE Z5NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW

INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING

REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD

REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD

REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1

REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE

REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1)

REAL*4 ADJFAC_REMCAP ! ADJ FACTOR FR REM CAP IN OP

REAL*4 SUM_REMCAP ! TOTAL REMAINING CAPACITY

REAL*4 ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY

REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO

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

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)
PR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

! opt 2

TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))

IF (TADDDMD .LE. 0.0) THEN

MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )

TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))

IF (CYCLE .EQ. 1) THEN

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

"FOR DEST, YEAR = ", DEST,MODYR

ENDIF

ENDIF

IF (TADDDMD .GE. 0.0) THEN ! note: this is true from above calc

! NET DMD INCREASES

! opt 4

! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)

IF (NET .EQ. PKNET) THEN

IF (SRC .GT. TNODES+SNODES) THEN ! storage

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)

ELSE IF(SRC .LE. TNODES) THEN ! pipe

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ELSE

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ENDDO

SUM_REMCAP = 0.0

DO A=ARC_1,ARC_2

IF (CUR_EFFCAP(NET,A) .GT. (MIN_PCTFLO*PRVFLOW(NET,A))) THEN

PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - &

(MIN_PCTFLO*PRVFLOW(NET,A))) ** ALPHAFAC

ELSE

PRV_REMCAP(A) = 0.0

ENDIF

SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)

ENDDO

INVPR_SUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

ARC_GAMMAFAC(A) = GAMMAFAC ! tmp: hardcoded

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN

INVPR_SUM = INVPR_SUM + &

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

ENDIF

ENDDO

SUMSHR = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0)) THEN

IF (NET .EQ. PKNET) THEN

ADJFAC_REMCAP = 1.0
ELSE ! add adj factor fr rem cap in OP

ADJFAC_REMCAP = float(N) * PRV_REMCAP(A) / SUM_REMCAP

ENDIF

ADDSHR(A) = ADJFAC_REMCAP * &

(((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

ELSE

ADDSHR(A) = 0.0

ENDIF

SUMSHR = SUMSHR + ADDSHR(A)

ENDDO

IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

ADDSHR(A) = ADDSHR(A) / SUMSHR

ADDDMD(A) = ADDSHR(A) * TADDDMD

NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)

ENDDO

ELSE

DO A=ARC_1,ARC_2

NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO

WRITE(NGOERR,*) " NEWFLOW: ",MODYR," ",A," ",NEWFLOW(A), &

" ",NODE_DMD(NET,DEST)

ENDDO

ENDIF

ELSE

WRITE(NGOERR,*) " ERROR Z5NG: NEED TO CHECK CALC OF ", &

"MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &

CURITR, CYCLE

ENDIF

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)

ENDDO

! CALL ZNGSHR_MAXCHK(DEST,NET,ADDSHR)

ENDIF ! end check for single arc into node

RETURN

END

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

!

! << OPTION 6 >>

! NEW SHARING ALGORITHM BASED ON ADDED DEMANDS AT NODE

! AND USING REMAINING FLOW (COMBINED OPT 2 & 4)

!

! 8/30/99

!

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

SUBROUTINE Z6NGSHR_CALC(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A,N ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC INTO DEST NODE

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK
INTEGER*4 FLGFLOW(ARCS) ! FLAG INDICATING POS/NEG FLOW

INTEGER*4 FLGSTOP ! FLAG USED TO STOP DO LOOP

REAL*4 PR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 SUMSHR ! SUM OF NEW SHR'S--USED FOR NORMALIZING

REAL*4 ADDSHR(ARCS) ! SHR OF ADDED NET NODE_DMD

REAL*4 ADDDMD(ARCS) ! ADDED NET NODE_DMD

REAL*4 TADDDMD ! TOTAL ADDED DMD AT NODE FROM T-1

REAL*4 NEWFLOW(ARCS) ! NEW FLOW INTO NODE

REAL*4 FLOWNEG ! TOTAL NEGATIVE FLOW

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS

REAL*4 PRV_REMCAP(ARCS) ! REMAINING CAPACITY USING FLOW(T-1)

REAL*4 SUM_REMCAP ! TOTAL REMAINING CAPACITY

REAL*4 ARC_GAMMAFAC(ARCS) ! ARC-SPECIFIC GAMMAFAC

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY

REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 MIN_PCTFLO ! LOCAL VARIABLE FOR PCTFLO

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

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

PR_SUM = 0.0

N = ARC_2 - ARC_1 + 1

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR) = 1.0

ELSE

! opt 2

TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))

IF (TADDDMD .LE. 0.0) THEN

MIN_PCTFLO = 0.95 * &

ABS(NODE_DMD(NET,DEST) / PRVNODE_DMD(NET,DEST) )

TADDDMD = NODE_DMD(NET,DEST) - &

(MIN_PCTFLO * PRVNODE_DMD(NET,DEST))

IF (CYCLE .EQ. 1) THEN

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

"FOR DEST, YEAR = ", DEST,MODYR

ENDIF

ENDIF

IF (TADDDMD .GE. 0.0) THEN

! NET DMD INCREASES

! opt 4

! set & sum rem cap for t-1

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)

IF (NET .EQ. PKNET) THEN

IF (SRC .GT. TNODES+SNODES) THEN ! storage

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A)

ELSE IF(SRC .LE. TNODES) THEN ! pipe

CUR_EFFCAP(NET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ELSE

CUR_EFFCAP(NET,A) = MAX_EFFCAP(NET,A)

ENDIF

ENDDO
SUM_REMCAP = 0.0

DO A=ARC_1,ARC_2

IF (CUR_EFFCAP(NET,A) .GT. PRVFLOW(NET,A)) THEN

PRV_REMCAP(A) = (CUR_EFFCAP(NET,A) - PRVFLOW(NET,A)) ** &

ALPHAFAC

ELSE

PRV_REMCAP(A) = 0.0

ENDIF

SUM_REMCAP = SUM_REMCAP + PRV_REMCAP(A)

ENDDO

INVPR_SUM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

ARC_GAMMAFAC(A) = SUM_REMCAP / PRV_REMCAP(A)

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(CUR_EFFCAP(NET,A).GT. 0.0)) THEN

INVPR_SUM = INVPR_SUM + &

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

ENDIF

ENDDO

SUMSHR = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0) .AND. &

(CUR_EFFCAP(NET,A).GT. 0.0)) THEN

ADDSHR(A) = &

(((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

!AAAA ADDSHR(A) = SHR(NET,A,MODYR-1) * FLOAT(N) *

!AAAA* (((1./ARC_SHRPR(NET,A))**ARC_GAMMAFAC(A)) / INVPR_SUM)

ELSE

ADDSHR(A) = 0.0

ENDIF

SUMSHR = SUMSHR + ADDSHR(A)

ENDDO

! opt 4

IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

ADDSHR(A) = ADDSHR(A) / SUMSHR

ADDDMD(A) = ADDSHR(A) * TADDDMD

NEWFLOW(A) = (PRVFLOW(NET,A) * MIN_PCTFLO) + ADDDMD(A)

ENDDO

ELSE

DO A=ARC_1,ARC_2

NEWFLOW(A) = PRVFLOW(NET,A) * MIN_PCTFLO

ENDDO

ENDIF

! opt 2

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

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

ELSE

WRITE(NGOERR,*) " ERROR Z6NG: NEED TO CHECK CALC OF ", &

"MIN_PCTFLO BECAUSE TADDDMD < 0.0 FOR NODE ",DEST, MODYR, &

CURITR, CYCLE

DO A=ARC_1,ARC_2

PR_SUM = PR_SUM + (ARC_SHRPR(NET,A) ** GAMMAFAC)

ENDDO

SUMSHR = 0.0

DO A=ARC_1,ARC_2

IF (PR_SUM .GT. 0.0) THEN

ADDSHR(A) = (ARC_SHRPR(NET,A)**GAMMAFAC) / &

PR_SUM

ELSE
ADDSHR(A) = 0.0

ENDIF

SUMSHR = SUMSHR + ADDSHR(A)

ENDDO

IF (SUMSHR .GT. 0.0) THEN

DO A=ARC_1,ARC_2

ADDSHR(A) = ADDSHR(A) / SUMSHR

ENDDO

ELSE

DO A=ARC_1,ARC_2

ADDSHR(A) = 0.0

ENDDO

ENDIF

! CHECK FOR NEGATIVE FLOW

FLGSTOP = 0

DO A=ARC_1,ARC_2

FLGFLOW(A) = 1

ENDDO

DO WHILE (FLGSTOP .EQ. 0)

FLOWNEG = 0.0

SUMSHR = 0.0

DO A=ARC_1,ARC_2

IF (FLGFLOW(A) .EQ. 1) THEN

ADDDMD(A) = ADDSHR(A) * TADDDMD

NEWFLOW(A) = (PRVFLOW(NET,A)*MIN_PCTFLO) + ADDDMD(A)

IF (NEWFLOW(A) .LT. 0.0) THEN

FLOWNEG = FLOWNEG + NEWFLOW(A)

NEWFLOW(A) = 0.0

ADDSHR(A) = 0.0

FLGFLOW(A) = 0

ELSE

FLGFLOW(A) = 1

SUMSHR = SUMSHR + ADDSHR(A)

ENDIF

ENDIF

ENDDO

IF (FLOWNEG .GE. 0.0) THEN

FLGSTOP = 1

ELSE

DO A=ARC_1,ARC_2

IF (FLGFLOW(A) .EQ. 1) THEN

ADDSHR(A) = ADDSHR(A) / SUMSHR

ENDIF

ENDDO

ENDIF

ENDDO ! end DO while flgstop = 0

ENDIF ! end check for added net dmd > 0

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = NEWFLOW(A) / NODE_DMD(NET,DEST)

ENDDO

ENDIF ! end check for single arc into node

RETURN

END

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! X

! ! X

! USE SHARING ALGORITHM TO CALCULATE SHARES ALONG ARCS INTO NODES ! X

! ! X
! STATUS: COMPLETE ! X

! ! X

! CALLED BY: NGDOWN_TREE ! X

! ! X

! = = = = = = = = = = = = = = = = = = = = = = = = = = = = ! X

SUBROUTINE XNGSHR_CALC(DEST,NET) ! X

IMPLICIT NONE ! X

! X

include 'parametr' ! x

include 'ngparinc' ! x

include 'ngtdminc' ! x

include 'ngitminc' ! x

! X

INTEGER*4 A ! COUNTERS ! X

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS ! X

INTEGER*4 DEST ! NODE ON TREE (DEST NODE) ! X

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

! X

REAL*4 INVPR_SUM ! TOTAL INVERSE PRICE FOR INPUT ARCS ! X

! X

! ------------- ! X

! X

ARC_1 = ARC_LOOP(NET,DEST,1) ! X

ARC_2 = ARC_LOOP(NET,DEST,2) ! X

INVPR_SUM = 0.0 ! X

! X

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE ! X

SHR(NET,ARC_1,MODYR) = 1.0 ! X

ELSE ! X

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS ! X

IF (ARC_SHRPR(NET,A) .GT. 0.0) THEN ! X

INVPR_SUM = INVPR_SUM + &

((1. / ARC_SHRPR(NET,A)) ** GAMMAFAC) ! X

ENDIF ! X

ENDDO ! X

! X

DO A=ARC_1,ARC_2 ! LOOP OVER ALL ARCS INTO DEST NODE

IF ((ARC_SHRPR(NET,A) .GT. 0.0) .AND. &

(INVPR_SUM .GT. 0.0)) THEN ! X

SHR(NET,A,MODYR) = MUFAC* SHR(NET,A,MODYR-1)+ (1.-MUFAC)* &

(((1./ARC_SHRPR(NET,A))**GAMMAFAC) / INVPR_SUM) ! X

ELSE ! X

SHR(NET,A,MODYR) = 0.0 ! X

ENDIF ! X

ENDDO ! X

ENDIF ! X

! X

RETURN ! X

END ! X

! X

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

!

! SET PK UTILIZATIONS BASED ON MONTHLY PK FLOWS

!

! STATUS: UNDER CONSTRUCTION

!

! CALLED BY: NGDOWN_TREE

!

! FUNCTIONS USED:

!

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

SUBROUTINE NGSHR_MTHCHK(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'
include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A,D,I ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CHNG, CHK, C ! FLAGS TO REDEFINE SHARES

INTEGER*4 MAXFLG(ARCS) ! FLAG INDICATING MAX CAP ON ARC

REAL*4 TMTH_CAP

REAL*4 TMTH_SHR

REAL*4 TINIT_CAPADD

REAL*4 INIT_CAPADD(ARCS)

REAL*4 MTH_REDC

REAL*4 MTH_CAP(ARCS)

REAL*4 MTH_NETNOD(TNODES)

REAL*4 MTHFLW(ARCS)

REAL*4 MTH_CAPADD(NETWORK,ARCS)

REAL*4 MTH_TCAPADD

! REAL*4 NEW_MTHCAP(NETWORK,ARCS)

REAL*4 NEW_MTHCAP(ARCS)

REAL*4 MTH_EXFLW

REAL*4 T_MTHFLW

REAL*4 CUR_PERCAP(ARCS)

REAL*4 NEW_PERCAP(ARCS)

REAL*4 PER_CAPADD(ARCS)

REAL*4 PERFAC

REAL*4 ALLOWBLD

REAL*4 NEW_EXFLW

REAL*4 NEWT_MTHFLW

REAL*4 ADDFLW

REAL*4 MTH_MAXCAP(ARCS)

REAL*4 TMTH_MAXCAP

REAL*4 MTHDMD24 ! PKMTH demand at node 24

REAL*4 MTHSTR(STNODES)! PKMTH storage

REAL*4 TMTH_STR ! total PKMTH storage

REAL*4 WXBLD ! extra builds due to weather factor

INTEGER*4 W,V

LOGICAL TMPSET/.TRUE./

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

IF (TMPSET) THEN

TMPSET = .FALSE.

ALLOWBLD = 1.0

IF (MODYR .LE. NOBLDYR) THEN

WXBLD = 0.0

ELSE

WXBLD = XBLD

ENDIF

ENDIF

TMTH_CAP = 0.0 ! INITIALIZE TOTAL PIPELINE MONTHLY CAP

TMTH_SHR = 0.0 ! INITIALIZE TOTAL SHR

TINIT_CAPADD = 0.0 ! INITIALIZE TOTAL PIPE CAP ADDITIONS

TMTH_MAXCAP = 0.0

IF (NET .EQ. PKNET) THEN

PERFAC = PKSHR_YR

ELSE

PERFAC = 1.-PKSHR_YR

ENDIF
ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! REDUCE MONTHLY CONS BY MONTHLY SUP AND STR FLOWS

MTH_REDC = 0.0

IF (NGDBGITR(4,7)) THEN

write(ngoerr,*) "ATTN11: YR,ITR,DEST,NODE_DMD,MTH_CONS,%= ", &

MODYR," ",CURITR," ",DEST," ",NODE_DMD(NET,DEST)," ", &

MTH_CONS(NET,DEST)," ",MTH_CONS(NET,DEST)/NODE_DMD(NET,DEST)

ENDIF

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .GT. TNODES+SNODES) THEN ! STORAGE

MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &

NODE_DMD(NET,DEST) * SPERMTH(NET,DEST))

ELSE IF (SRC .GT. TNODES) THEN ! SUPPLY

MTH_REDC = MTH_REDC + (SHR(NET,A,MODYR) * &

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

!! NODE_DMD(NET,DEST) * PPERMTH(NET,DEST)) !by ng reg

ELSE ! PIPELINE ARCS

CUR_PERCAP(A) = PERFAC * CURPCAP(A,MODYR)

NEW_PERCAP(A) = SHR(NET,A,MODYR) * NODE_DMD(NET,DEST) ! don't use xbld here

IF (NEW_PERCAP(A) .GT. CUR_PERCAP(A)) THEN

! ALLOWBLD=1 unless want to restrict blds

PER_CAPADD(A) = ALLOWBLD * (NEW_PERCAP(A) - CUR_PERCAP(A))

ELSE

PER_CAPADD(A) = 0.0

ENDIF

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

TMTH_CAP = TMTH_CAP + MTH_CAP(A)

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

TMTH_MAXCAP = TMTH_MAXCAP + MTH_MAXCAP(A)

TMTH_SHR = TMTH_SHR + SHR(NET,A,MODYR)

ENDIF

ENDDO

! PIPELINE ARCS

MTH_NETNOD(DEST) = (MTH_CONS(NET,DEST) - MTH_REDC) * &

(1. + WXBLD) ! weather impact on dmd

IF (MTH_NETNOD(DEST) .GE. (TMTH_MAXCAP+0.001)) THEN

! keep this write

WRITE(NGOERR,30) DEST,modyr,curitr, &

mth_netnod(dest),tmth_maxcap,tmth_cap

30 FORMAT (1X,'ATTN9: NGSHR_MTHCHK MAX CAP ERROR, dest=', &

I4,' year,itr= ',I4,I4,' mth_netnod(dest),tmth_maxcap,tmth_cap ', &

3F10.2)

ENDIF

! IF CANADIAN NODE 24, REDEFINE STR PKMTH FACTOR (SPERMTH)

IF (DEST .EQ. TNODES-LNGNODES) THEN ! Canadian node 24

! IF (NGDBGITR(4,7)) THEN

WRITE(NGOERR,40) MTH_NETNOD(DEST), MTH_REDC, DEST, &

modyr,curitr

40 FORMAT (1X,'ATTN10: NGSHR_MTHCHK MTH_NETNOD demand, ', &

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

! ENDIF

IF (ABS(MTH_NETNOD(DEST) / MTH_REDC) .GT. .01) THEN

! redefine str PKMTH factor

TMTH_STR = 0.0

DO I=1,STNODES
D = STR_2NODE(I)

A = NODE_2ARC(TNODES+SNODES+I,D)

MTHSTR(I) = (SHR(NET,A,MODYR) * (1. +WXBLD) * &

NODE_DMD(NET,D) * SPERMTH(NET,D))

TMTH_STR = TMTH_STR + MTHSTR(I)

IF (D .EQ. TNODES-LNGNODES) THEN ! Canadian node 24

MTHDMD24 = MTH_NETNOD(D)

ENDIF

ENDDO

DO I=1,STNODES

D = STR_2NODE(I)

SPERMTH(NET,D) = SPERMTH(NET,D) * &

((TMTH_STR + MTHDMD24) / TMTH_STR)

IF (I .EQ. 14) THEN

WRITE(NGOERR,50) D,SPERMTH(NET,D),MTHSTR(I),TMTH_STR

50 FORMAT (1X,'ATTN10: NGSHR_MTHCHK new SPERMTH for reg ', &

I4,' = ',F10.7,' MTHSTR= ',F10.2, ' TMTH_STR= ',F10.2)

ENDIF

IF (NGDBGITR(4,7)) THEN

WRITE(NGOERR,*) "ATTN10: NGSHR_MTHCHK new SPERMTH for", &

" reg ",D," = ",SPERMTH(NET,D)," MTHSTR= ",MTHSTR(I), &

" TMTH_STR= ",TMTH_STR

ENDIF

ENDDO

ENDIF

ENDIF

! TOTAL MONTHLY PIPELINE CAP ADDITIONS NEEDED

MTH_TCAPADD = AMAX1( (MTH_NETNOD(DEST) - TMTH_CAP), 0.0 )

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

IF (TMTH_SHR .GT. 0.0) THEN

MTHFLW(A) = MTH_NETNOD(DEST) * &

(SHR(NET,A,MODYR) / TMTH_SHR)

ELSE

MTHFLW(A) = 0.0

ENDIF

INIT_CAPADD(A) = AMAX1( (MTHFLW(A) - MTH_CAP(A)), 0.0 )

TINIT_CAPADD = TINIT_CAPADD + INIT_CAPADD(A)

ENDIF

ENDDO

! SET NEW CAPACITY ALONG PIPELINE ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

IF (TINIT_CAPADD .GT. 0.0) THEN

MTH_CAPADD(NET,A) = MTH_TCAPADD * &

(INIT_CAPADD(A) / TINIT_CAPADD)

ELSE

MTH_CAPADD(NET,A) = 0.0

ENDIF

NEW_MTHCAP(A) = MTH_CAP(A) + MTH_CAPADD(NET,A)

IF (NGDBGITR(4,7)) THEN

WRITE(NGOERR,22) MODYR,CURITR,SRC,DEST, &

MTH_CAP(A),NEW_MTHCAP(A),MTH_MAXCAP(A)

ENDIF

22 FORMAT(' ATTN22: YR,ITR,SRC,DEST,MTHCAP,NEW_,MAX_= ', &

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

ENDIF
ENDDO

! CHECK IF NEW_MTHCAP > MTH_MAXCAP

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

! CHECK IF MONTHLY FLOWS EXCEED MONTHLY PK CAP AND REALLOCATE

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

! ADD MONTHLY FLOWS TO MONTHLY SRC PK DEMAND NODE

! AND ADD EXTRA CAPACITY AS CONTINGENCY

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

MTH_CONS(NET,SRC) = MTH_CONS(NET,SRC) + &

MTHFLW(A) /(1. + WXBLD) ! rmv weather impact on dmd

ENDIF

! stores new annual cap in opnet position

IF (SRC .LE. DNODES) THEN ! PIPELINE ARCS

IF (NET .EQ. PKNET) THEN

MAXPCAP(OPNET,A) = NEW_MTHCAP(A) / (PERMTH(NET)*PERFAC)

IF (MAXPCAP(OPNET,A) .GT. MAXPCAP(PKNET,A)) THEN

MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

ENDIF

ENDIF

ENDIF

ENDDO

RETURN

END

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

!

! CHECK IF MAXIMUM FLOW OR CAPACITY IS EXCEEDED AND REALLOCATE

!

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

SUBROUTINE NGFLW_MTHMAX(ID,NET,DEST,FLW,CAP)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

INTEGER*4 ID, NET, DEST, SRC

INTEGER*4 A, ARC_1, ARC_2

INTEGER*4 C, CHNG, CHK

INTEGER*4 MAXFLG(ARCS)

INTEGER*4 CNT ! count number of pipeline arcs into node

REAL*4 FLW(ARCS)

REAL*4 CAP(ARCS)

REAL*4 ADDFLW

REAL*4 EXFLW

REAL*4 T_FLW

REAL*4 NEW_EXFLW

REAL*4 NEWT_FLW

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

ARC_1 = ARC_LOOP(NET,DEST,1)

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

DO A=ARC_1,ARC_2 ! COUNT NUM OF PIPELINE ARCS INTO NODE

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN

CNT = CNT+1

ENDIF

ENDDO

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

RETURN

ENDIF

EXFLW = 0.0

T_FLW = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

IF (FLW(A) .GE. CAP(A)) THEN

EXFLW = EXFLW + (FLW(A)-CAP(A))

FLW(A) = CAP(A)

MAXFLG(A) = 1

ELSE

T_FLW = T_FLW + FLW(A)

MAXFLG(A) = 0

ENDIF

ENDIF

ENDDO

C = 1

CHNG = 1

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

CHK = 0

NEW_EXFLW = 0.0

NEWT_FLW = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

IF (MAXFLG(A) .EQ. 0) THEN

ADDFLW = EXFLW * (FLW(A) / T_FLW)

IF (ADDFLW .GE. (CAP(A) - FLW(A))) THEN

CHK = 1

MAXFLG(A) = 1

NEW_EXFLW = NEW_EXFLW + (ADDFLW - &

(CAP(A) - FLW(A)))

FLW(A) = CAP(A)

ELSE

FLW(A) = FLW(A) + ADDFLW

NEWT_FLW = NEWT_FLW + FLW(A)

ENDIF

ENDIF

ENDIF

ENDDO

EXFLW = NEW_EXFLW

T_FLW = NEWT_FLW

CHNG = CHK

C = C+1

ENDDO

IF (C .GT. 20) THEN

WRITE(NGOERR,*) "ATTN8: MTH CAP REALLC INCOMPLETE FOR ", &

MODYR, CURITR, " NET= ",NET, " DEST= ",DEST," ID= ",ID

ENDIF
RETURN

END

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

!

! IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP

!

! STATUS: COMPLETE

!

! CALLED BY: NGDOWN_TREE

!

! FUNCTIONS USED: NGSET_MAXFLO

!

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

SUBROUTINE NGSHR_MAXCHK(DEST,NET)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES

INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)

INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR

REAL*4 SUMMAX ! TOTAL SHARES AT MAX SHR

REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION

REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

TMAXFLO = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

OLDFLG(A) = 0.

MAXFLG(A) = 0.

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHRMAX(A) = SHR(NET,A,MODYR) * 1.2 ! temp ???????? OK?

ENDIF

TMAXFLO = TMAXFLO + MAXFLO(NET,A)

ENDDO

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

CHNG = 1

DO WHILE (CHNG .EQ. 1)

CHK = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN

SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW

MAXFLG(A) = 1
IF (MAXFLG(A) .NE. OLDFLG(A)) THEN

CHK = 1

OLDFLG(A) = MAXFLG(A)

ENDIF

ENDIF

ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS

SUMMAX = 0.0

SUMREM = 0.0

SUMSHR = 0.0

CNT0 = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

CNT0 = CNT0 + 1

SUMSHR = SUMSHR + SHR(NET,A,MODYR)

ELSE

SUMMAX = SUMMAX + SHR(NET,A,MODYR)

ENDIF

ENDDO

SUMREM = 1. - (SUMSHR+SUMMAX)

! DISTRIBUTE OVER UNCONSTR ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

IF (SUMSHR .GT. 0.0) THEN

SHR(NET,A,MODYR) = (1. + (SUMREM/SUMSHR)) * &

SHR(NET,A,MODYR)

ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN

SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)

ENDIF

ENDIF

ENDDO

ELSE

CHNG = 0

ENDIF

ENDDO

ELSE ! SET BKSTOP EQUAL TO EXCESS DEMAND AND RESET SHARES

BKSTOP(NET,DEST) = NODE_DMD(NET,DEST) - TMAXFLO

!CCC BKSTOP_FLG = 1

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR) = SHRMAX(A)

ENDDO

WRITE(NGOERR,100) & ! ATTN

MODYR, CYCLE, NET, DEST, BKSTOP(NET,DEST), NODE_DMD(NET,DEST), &

TMAXFLO, RBKSTOP_PADJ(NET,DEST)

ENDIF

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

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

RETURN

END

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

!

! IF SHARES EXCEED MAX, REALLOCATE SHARES OR SET BKSTOP

!

! STATUS: COMPLETE

!

! CALLED BY: NGDOWN_TREE
!

! FUNCTIONS USED: NGSET_MAXFLO

!

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

SUBROUTINE ZNGSHR_MAXCHK(DEST,NET,ADDSHR)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CNT0 ! NUMBER OF ARCS NOT EXCEEDING MAX SHR

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES

INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)

INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 SUMSHR ! TOTAL SHARES NOT AT MAX SHR

REAL*4 SUMREM ! TOTAL SHARES REMAINING FOR DISTRIBUTION

REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

REAL*4 ADDSHR(ARCS) ! SHARES OF FLOW ADDED TO T-1

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

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

TMAXFLO = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

OLDFLG(A) = 0.

MAXFLG(A) = 0.

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION

IF (NODE_DMD(NET,DEST) .GT. 0.0) THEN

SHRMAX(A) = MAXFLO(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHRMAX(A) = SHR(NET,A,MODYR) * 1.2 ! temp ???????? OK?

ENDIF

TMAXFLO = TMAXFLO + MAXFLO(NET,A)

ENDDO

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

CHNG = 1

DO WHILE (CHNG .EQ. 1)

CHK = 0

SUMREM = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (SHR(NET,A,MODYR) .GE. SHRMAX(A)) THEN

SUMREM = SUMREM + (SHRMAX(A) - SHR(NET,A,MODYR))

SHR(NET,A,MODYR) = SHRMAX(A) ! SET FLOW = MAX FLOW

MAXFLG(A) = 1

IF (MAXFLG(A) .NE. OLDFLG(A)) THEN

CHK = 1

OLDFLG(A) = MAXFLG(A)

ENDIF

ENDIF

ENDDO

IF (CHK .EQ. 1) THEN ! NEED TO REALLOCATE SHR OVER ARCS

SUMSHR = 0.0
CNT0 = 0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

CNT0 = CNT0 + 1

SUMSHR = SUMSHR + ADDSHR(A)

ENDIF

ENDDO

! DISTRIBUTE OVER UNCONSTR ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

IF (MAXFLG(A) .EQ. 0) THEN

IF (SUMSHR .GT. 0.0) THEN

SHR(NET,A,MODYR) = (SUMREM*ADDSHR(A)/SUMSHR) + &

SHR(NET,A,MODYR)

ELSE IF ((SHR(NET,A,MODYR) .LE. 0.0) .AND. &

(CNT0 .GT. 0)) THEN

SHR(NET,A,MODYR) = SUMREM / FLOAT(CNT0)

ENDIF

ENDIF

ENDDO

ELSE

CHNG = 0

ENDIF

ENDDO

ENDIF

RETURN

END

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

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

!

! FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE

!

! STATUS: COMPLETE

!

! CALLED BY: NGSHR_MAXCHK

!

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

REAL FUNCTION NGSET_MAXFLO(NET,A)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 A ! COUNTER

INTEGER*4 SRC ! NODE ON TREE (SOURCE)

INTEGER*4 DEST ! NODE ON TREE (DESTINATION)

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION

REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION

REAL*4 XCAP ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW

REAL*4 DELXCAP ! EXTRA CAP BUILD DUE TO WEATHER

REAL*4 XNGSET_MAXFLO !utz

! ---------

NGSET_MAXFLO = XNGSET_MAXFLO(NET,A) !utz

RETURN !utz

SRC = ARC_2NODE(A,1)

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

PKFAC = PKUTZ(A)

OPFAC = OPUTZ(A) ! NOTE: = 0.0

ELSE ! PIPELINE OR SUPPLY ARC

PKFAC = PKSHR_YR * PKUTZ(A)

OPFAC = (1.-PKSHR_YR) * OPUTZ(A)

ENDIF

IF (NET .EQ. PKNET) THEN ! PEAK

NGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC

ELSE ! OFFPEAK

IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR. &

((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN ! SUPPLY (NO LNG)-or- FLORIDA

! NO CURPCAP FOR SUPPLY

MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

ELSE ! PIPE AND STORAGE

XCAP = FLOW(PKNET,A) / PKFAC

IF (XCAP .GT. CURPCAP(A,MODYR)) THEN

MAXPCAP(OPNET,A) = XCAP

ELSE

MAXPCAP(OPNET,A) = CURPCAP(A,MODYR)

ENDIF

ENDIF

NGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC

ENDIF

RETURN

END

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

!

! FUNCTION TO SET MAXIMUM ALLOWABLE FLOW ALONG EACH ARC TYPE

!

! STATUS: used with monthly calculation of cap adds

!

! CALLED BY: NGSHR_MAXCHK

!

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

REAL FUNCTION XNGSET_MAXFLO(NET,A)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 A ! COUNTER

INTEGER*4 SID ! NODE ON SUPPLY COUNT (1-97)

INTEGER*4 LID ! NODE ON LNG SUPPLY COUNT (1-3)

INTEGER*4 SRC ! NODE ON TREE (SOURCE)

INTEGER*4 DEST ! NODE ON TREE (DESTINATION)

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION

REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION

REAL*4 XCAP ! PLACEHOLDER FOR EQUIV. ANNUAL CAP FROM PK FLOW

REAL*4 DELXCAP ! EXTRA CAP BUILD DUE TO WEATHER

REAL*4 OPCAP ! PLACEHOLDER FOR NEW ANNUAL CAP

! ---------

SRC = ARC_2NODE(A,1)

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

PKFAC = PKUTZ(A)

OPFAC = OPUTZ(A) ! NOTE: = 0.0

ELSE ! PIPELINE OR SUPPLY ARC

PKFAC = PKSHR_YR * PKUTZ(A)

OPFAC = (1.-PKSHR_YR) * OPUTZ(A)

ENDIF

SID = SRC-TNODES ! SUPPLY NODE COUNT (1-97)

IF (SID .GE.FSRGN(14) .AND. SID .LE.FSRGN(14)+NSRGN(14)-1) THEN ! LNG SUPPLY 

!JBEMAX

LID = SID - FSRGN(14)+1 ! LNG SUPPLY COUNT (1-3)

XNGSET_MAXFLO = MAXPLNG(LID,NET,MODYR) !JBEMAX

ELSE !JBEMAX

IF (NET .EQ. PKNET) THEN ! PEAK

XNGSET_MAXFLO = MAXPCAP(PKNET,A) * PKFAC

ELSE ! OFFPEAK

IF ( ((SRC.GT.TNODES) .AND. (SRC.LE.(TNODES+SNODES))) .OR. &

((SRC.EQ.6) .AND. (DEST.EQ.10)) ) THEN ! SUPPLY -or- FLORIDA

! NO CURPCAP FOR SUPPLY

MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

! storage, imports, or nobldyr

ELSE

XCAP = FLOW(PKNET,A) / PKFAC

IF (XCAP .GT. CURPCAP(A,MODYR)) THEN

OPCAP = XCAP

ELSE

OPCAP = CURPCAP(A,MODYR)

ENDIF !xutz

IF ((SRC.LE.DNODES) .AND.(MAXPCAP(OPNET,A).GT.OPCAP)) THEN !xutz

WRITE(NGOERR,60) MODYR,SRC,DEST,MAXPCAP(OPNET,A),OPCAP !xutz

60 FORMAT(1X,'XNGSET_MAXFLO: YR,SRC,DEST,MAX,OPCAP', & !xutz

3I5,2F10.2) !xutz

CONTINUE ! use value set in NGSHR_MTHCHK !xutz

ELSE !xutz

MAXPCAP(OPNET,A) = OPCAP

ENDIF

ENDIF

XNGSET_MAXFLO = MAXPCAP(OPNET,A) * OPFAC

ENDIF

ENDIF !JBEMAX

RETURN

END

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

!

! CHECK CONVERGENCE ON SUPPLY PRICE

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! CALLS : NGSET_SUPPR

!

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

SUBROUTINE NGCHK_CONVNG

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

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

INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP)

INTEGER*4 CFLG ! CONVERGE FLAG FOR CYCLING UP/DOWN TREE

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

DO NET=1,NETWORK

DO N=1,NODES

NODE_ENDPR(NET,N) = 0.0

NODE_SHRPR(NET,N) = 0.0

ENDDO

ENDDO

DO NET=1,NETWORK

DO S=1,SNODES

N = TNODES + S

IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N)

ENDDO

ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

CALL NGSET_SUPPR

! SET SCALE FACTOR FOR L48 & OFFSHORE WELLHEAD PRICE

IF (MODYR .GT. EHISYR) THEN

CALL NGSTEO_BENCHWPR

ENDIF

! CHECK FOR CONVERGENCE IF CYCLE > 1

DO NET=1,NETWORK

DO S=1,SNODES

IF (SUPARRAY(S).EQ.1) THEN

PSUP_CNVG(NET,S) = 1

QSUP_CNVG(NET,S) = 1

ENDIF

ENDDO

ENDDO

CFLG = 1

IF (CYCLE .GT. 1) THEN

DO NET=1,NETWORK

DO S=1,SNODES ! LOOP OVER SUPPLY NODES

IF (SUPARRAY(S).EQ.1) THEN

DELTA = ABS(NODE_PSUP(NET,S) - NODE_PSUPPREV(NET,S)) / &

NODE_PSUPPREV(NET,S)

IF (DELTA .LE. PSUP_DELTA) THEN

PSUP_CNVG(NET,S) = 1

ELSE

PSUP_CNVG(NET,S) = 0

QSUP_CNVG(NET,S) = 0

CFLG = 0

IF (NODE_QSUP(NET,S) .LE. (QSUP_SMALL*SHRYR(NET))) THEN

DELTA = ABS(NODE_QSUP(NET,S)-NODE_QSUPPREV(NET,S)) / &

NODE_QSUPPREV(NET,S)

IF (DELTA .LE. QSUP_DELTA) THEN

QSUP_CNVG(NET,S) = 1

CFLG = 1

ENDIF

ENDIF

ENDIF
IF (CFLG.EQ.0) GO TO 100

ENDIF

ENDDO

ENDDO

DO NET=1,NETWORK

DO N=1,TNODES

IF (BKSTOP(NET,N) .GT. 0.0) THEN

CFLG = 0

ENDIF

ENDDO

ENDDO

100 CONTINUE

! IF NOT CONVERGED, SET NEW RELAXED SUPPLY QTY AND

! GET NEW WELLHEAD PRICE BEFORE GOING UP TREE

IF (CFLG .EQ. 0) THEN

!CCC IF ((CFLG .EQ. 0) .OR. (BKSTOP_FLG .EQ. 1)) THEN

!CCC IF (BKSTOP_FLG .EQ. 1) THEN

!CCC BKSTOP_PADJ = BKSTOP_PADJ + 1.

!CCC ENDIF

CNVGFLG = 0

DO NET=1,NETWORK

DO S=1,SNODES ! LOOP OVER SUPPLY NODES

!CCC IF (PSUP_CNVG(NET,S).EQ.0 .AND. QSUP_CNVG(NET,S).EQ.0) THEN

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

(1.-QSUP_WT)* NODE_QSUPPREV(NET,S)

!CCC ENDIF

ENDDO

ENDDO

CALL NGSET_SUPPR

IF (MODYR .GT. EHISYR) THEN

CALL NGSTEO_BENCHWPR ! SET SCALE FAC FOR ON/OFFSHORE WELLHEAD PRICE

ENDIF

ELSE

CNVGFLG = 1

WRITE(NGOERR,*) 'CONVERGED ON CYCLE= ',CYCLE, &

' ITR= ',CURITR,' YEAR= ',MODYR, ' ! ATTN4'

ENDIF

ENDIF

DO NET=1,NETWORK

DO S=1,SNODES

IF (SUPARRAY(S).EQ.1) THEN

N = TNODES + S

NODE_ENDPR(NET,N) = NODE_PSUP(NET,S)

NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S)

NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S)

ENDIF

ENDDO

ENDDO

RETURN

END

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

!

! USE SUPPLY CURVES AND QTY TO SET WELLHEAD PRICES

!

! STATUS: COMPLETE

!
! CALLED BY: NGTDM_ITM

!

! FUNCTIONS USED: NGSUP_PR

!

! NOTES: MAY WANT TO CHANGE PK/OP ALGORITHM

!

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

SUBROUTINE NGSET_SUPPR

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

include 'nghistinc'

include 'ngtdminc'

INTEGER*4 N,S,M,MX ! COUNTERS

INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP)

REAL*4 PKPR, OPPR ! TEMP PK,OP SUP PRICES

REAL*4 PQ ! SUM OF P*Q

REAL*4 SPAVG(SNODES) ! QTY WEIGHTED AVG OF PK & OP

REAL*4 FSF ! FINE SCALING FACTOR

REAL*4 SQSUP(NETWORK) ! SEASONAL SUPPLY QTY

REAL*4 SPSUP(NETWORK) ! SEASONAL SUPPLY PRICE

REAL*4 ANNSUP ! EQUIVALENT ANNUAL SUPPLY FROM PK,OP SUPPLY

REAL*4 NGSUP_PR ! SUPPLY CURVE FUNCTION

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION

REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION

REAL*4 NGPRCLNG ! LNG SUPPLY CURVE FUNCTION

REAL*4 QLAGTOT(NETWORK,NLNGCRV) ! LNG IMPORTS LAST YEAR, EAST AND WEST

REAL*4 TOTQ(NETWORK,NLNGCRV) ! IMPORT LEVELS IN EAST AND WEST (LAST YEAR, THIS 

YEAR)

REAL*4 MEXLNGTOT ! TOTAL MEXICO LNG IMPORTS ON GIVEN COAST

REAL*4 SH ! TEMPORARY HOLD SEASONAL MEXICO SHARE

REAL*4 DUMMY ! DUMMY ARGUMENT WHEN NOT NEEDED BY FUNCTION

! ---------

PKFAC = PKSHR_YR

OPFAC = (1.-PKSHR_YR)

DO S=1,SNODES ! VARIABLE SUPPLY, 1-20,21

PQ = 0.0

RPSHIFT(S) = 0.0

IF(SUPTYPE(S).NE.14 .AND. FIXLNGFLG) THEN

PSUP(S) = 0.0

QSUP(S) = 0.0

ENDIF

IF (SUPARRAY(S).EQ.1) THEN

QSUP(S) = NODE_QSUP(PKNET,S) + NODE_QSUP(OPNET,S)

N = S + TNODES ! NODE ID

IF(SUPTYPE(S).NE.14) THEN ! NON-LNG

PSUP(S) = NGSUP_PR('Q',QSUP(S),S) !*FUNCTION

IF (MODYR .LE. EHISYR) THEN

RPSHIFT(S) = HPSUP(S,MODYR) - PSUP(S)

HIST_RPSHIFT(S,MODYR) = RPSHIFT(S)

PSUP(S) = HPSUP(S,MODYR)

ENDIF

IF (S.EQ.18 .AND. (ZOGRESNG(18).LE.0.0 .OR. ZOGPRRNG(18).LE.0.0)) PSUP(S) = 

PSUP(8) - 0.15

DO NET=1,NETWORK

IF (NET .EQ. PKNET) THEN ! PK
ANNSUP = NODE_QSUP(NET,S) / PKFAC

ELSE ! OP

ANNSUP = NODE_QSUP(NET,S) / OPFAC

ENDIF

SQSUP(NET) = NODE_QSUP(NET,S)

SPSUP(NET) = NGSUP_PR('Q',ANNSUP,S) !*FUNCTION

PQ = PQ + SPSUP(NET) * SQSUP(NET)

ENDDO

IF (QSUP(S) .GT. 0.) THEN

SPAVG(S) = PQ / QSUP(S)

ELSE

SPAVG(S) = PSUP(S)

ENDIF

FSF = PSUP(S) / SPAVG(S)

DO NET=1,NETWORK

NODE_PSUP(NET,S) = SPSUP(NET) * FSF

ENDDO

ELSE ! LNG

M = S - FSRGN(14) + 1

IF (QSUP(S) .GT. 0.0) THEN

PKSHR_PROD(S) = NODE_QSUP(PKNET,S)/QSUP(S) !DEFINE LNG SHARE HERE?

ELSE

PKSHR_PROD(S) = PKSHR_YR

ENDIF

IF (MODYR.LE.LHISYR) THEN

DO NET=1,NETWORK

NODE_PSUP(NET,S) = HPLNG(NET,4,MODYR) ! GULF OF MEXICO PRICE

PSUP(S) = HPSUP(S,MODYR)

ENDDO

ELSE ! forcast

IF (LNGCRVOPT.EQ.6) THEN ! TOTAL N.AMER CURVE

SQSUP = 0.0

ANNSUP = 0.0

DO NET=1,NETWORK

IF (NET.EQ.PKNET) THEN

SH = PKSHR_EMEX

ELSE

SH = 1.-PKSHR_EMEX

ENDIF

DO MX=1,NUMREG

SQSUP(NET) = SQSUP(NET) + MEXLNG(MX,MODYR) * SH

ANNSUP = ANNSUP + MEXLNG(MX,MODYR) * SH

ENDDO

DO N=FSRGN(14),FSRGN(14)+NSRGN(14)-1 ! ADD EAST AND WEST

SQSUP(NET) = SQSUP(NET) + NODE_QSUP(NET,N)

ANNSUP = ANNSUP + NODE_QSUP(NET,N)

ENDDO

ENDDO

! if using seasonal curves

DO NET=1,NETWORK

NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,SQSUP(NET),'Q',DUMMY) !*LNG 

FUNCTION (LAG NOT USED)

PQ = PQ + ( NODE_PSUP(NET,S) * SQSUP(NET) )

ENDDO

IF (ANNSUP .GT. 0.) THEN
SPAVG(S) = PQ / ANNSUP

ELSE

SPAVG(S) = PSUP(9)

ENDIF

PSUP(S) = SPAVG(S)

! when have annual curves

!

! PSUP(S) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY) !*LNG FUNCTION 

(LAG NOT USED)

! DO NET=1,NETWORK

! IF (NET .EQ. PKNET) THEN ! PK

! ANNSUP = SQSUP(NET) / PKFAC

! ELSE ! OP

! ANNSUP = SQSUP(NET) / OPFAC

! ENDIF

! SPSUP(NET) = NGPRCLNG(M,NET,MODYR,ANNSUP,'Q',DUMMY) !*LNG 

FUNCTION (LAG NOT USED)

! PQ = PQ + ( SPSUP(NET) * SQSUP(NET) )

! ENDDO

!

! IF ((SQSUP(PKNET) + SQSUP(OPNET)) .GT. 0.) THEN

! SPAVG(S) = PQ / (SQSUP(PKNET) + SQSUP(OPNET))

! ELSE

! SPAVG(S) = PSUP(S)

! ENDIF

! FSF = PSUP(S) / SPAVG(S)

!

! DO NET=1,NETWORK

! NODE_PSUP(NET,S) = SPSUP(NET) * FSF

! ENDDO

ELSE

TOTQ(PKNET,M) = NODE_QSUP(PKNET,S)

TOTQ(OPNET,M) = NODE_QSUP(OPNET,S)

DO NET=1,NETWORK

IF (NET.EQ.PKNET) THEN

SH = PKSHR_EMEX

ELSE

SH = 1.-PKSHR_EMEX

ENDIF

QLAGTOT(NET,M) = NODE_QSUPPREV(NET,S)

IF (M.EQ.1) THEN

MEXLNGTOT = (MEXLNG(2,MODYR) + MEXLNG(4,MODYR)) * SH

ELSEIF (M.EQ.2) THEN

MEXLNGTOT = (MEXLNG(1,MODYR) + MEXLNG(3,MODYR) + MEXLNG(5,MODYR)) * SH

ENDIF

QLAGTOT(NET,M) = QLAGTOT(NET,M) + MEXLNGTOT

TOTQ(NET,M) = TOTQ(NET,M) + MEXLNGTOT

NODE_PSUP(NET,S) = NGPRCLNG(M,NET,MODYR,TOTQ(NET,M),'Q',QLAGTOT(NET,M)) 

!*LNG FUNCTION

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

CORRECT?

ENDDO

IF ((TOTQ(PKNET,M)+TOTQ(OPNET,M)).GT.0.0) THEN

PSUP(S)= PQ / (TOTQ(PKNET,M)+TOTQ(OPNET,M))

ELSE

PSUP(S)= 1.0 ! NOT NECESSARILY BEST FALLBACK

ENDIF

ENDIF

ENDIF

ENDIF
ENDIF

ENDDO

RETURN

END

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

! PLACEHOLDER FOR SUPPLY CURVE FUNCTIONS

! The new OGSM supply curves will be estimating equations

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_SUPPR

!

! NOTES: -SUP CRV INCLUDES PROD FOR L&P

! -INCREASE SUP QTY BY L&P % BEFORE USING SUP CRV

!

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

REAL FUNCTION NGSUP_PR(INVAL,VALUE,IREG)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

include 'ngsteoinc'

include 'ogglobal'

! DETERMINES LEVEL OF PRODUCTION OR WELLHEAD PRICE GIVEN A PRICE OR

! A LEVEL OF DESIRED PRODUCTION (RESPECTIVELY) FOR THE REQUESTED

! NGTDM/OGSM REGION (ONSHORE, OFFSHORE, CANADA: 1-21)

INTEGER*4 IREG ! NGTDM/OGSM REGION (1-21)

INTEGER*4 NREG ! NGTDM REGION (1-12)

INTEGER*4 IVREG ! NGTDM/OGSM REGION for variable supply

INTEGER*4 I,J ! COUNTER

INTEGER*4 N,S ! COUNTER

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

INTEGER*4 NG /2/ ! temp: kevsup

INTEGER*4 R

INTEGER*4 ICNT ! COUNTER

REAL*4 QBASE ! REFERENCE QUANTITY POINT

REAL*4 PBASE ! REFERENCE PRICE POINT

REAL*4 XQBASE ! RESERVES*(P/R)

REAL*4 XPBASE ! PRICE ASSOCIATED W/XQBASE

REAL*4 AQBASE ! QUANTITY AT PERCENT BELOW XQBASE

REAL*4 APBASE ! PRICE ASSOCIATED W/AQBASE

REAL*4 BQBASE ! QUANTITY AT PERCENT ABOVE XQBASE

REAL*4 BPBASE ! PRICE ASSOCIATED W/BPBASE

REAL*4 CQBASE ! QUANTITY AT PERCENT BELOW AQBASE

REAL*4 CPBASE ! PRICE ASSOCIATED W/CQBASE

REAL*4 DQBASE ! QUANTITY AT PERCENT ABOVE BQBASE

REAL*4 DPBASE ! PRICE ASSOCIATED W/DPBASE

REAL*4 QVAR ! TEMPORARY HOLDING ARRAY

REAL*4 MIN_NA ! MINIMUM ALLOWED NA PRODUCTION

REAL*4 VALUE ! INPUT PRICE OR QUANTITY

REAL*4 FIXSUP ! "FIXED" SUPPLY QUANTITY

REAL*4 ELAS ! SUPPLY CURVE "ELASTICITY"

CHARACTER*1 INVAL ! CHARACTER INDICATING IF THE INPUT

! VALUE IS A PRICE OR QUANTITY

REAL*4 QSHFT ! SHIFT CN SUPPLY CURVE (TEMP CODE)
REAL*4 X ! HOLDS INTERMEDIATE VALUE

REAL*4 PRCIN ! INPUT PRICE ADJUSTED

REAL*4 INITINP4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=P

REAL*4 INITINQ4(20) ! FOR CUR=4, TEMP HOLD VALUE WHEN INVAL=Q

REAL*4 PRRLAG(20) ! PREVIOUS YEAR'S P/R RATIO

REAL*4 WPRLAG(20) ! PREVIOUS YEAR'S WELLHEAD PRICE

REAL*4 NEWVAL ! P/R RATIO FOR OPTION 2

REAL*4 PERCNT ! PCT L&P AFTER SCALING

REAL*4 REG_CNST(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST1(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST2(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST3(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST4(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST5(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 REG_CNST6(21) ! REGIONAL CONSTRANTS FOR WOP BASED P0 CALC

REAL*4 BETA1,BETA2,BETA3,TMPUS

REAL*4 CNC,CNRHO,CNB1,CNPRLAG,TMPCAN,CNDL

REAL*4 AVGWOP, AVGNGP, POST2000

REAL*4 HDD, HDDLAG, L48_RA, L48_PRD, UGRSHR, REPRATE, ONCONVSHR, UGRRESSHR, 

UGRRESSHRLAG

REAL*4 A1, B1, B2, B3, B4, B5, RHO

REAL*4 Z1,Z2,Z3,Z4,Z5,Z6,Z7

! EPA ADDED VARIABLES

REAL*4 U_PROD_CONV(17)

REAL*4 U_PROD_TIGHT(17)

REAL*4 U_PROD_SHALE(17)

REAL*4 U_PROD_CBM(17)

REAL*4 NG_REDUCT_NEW

REAL*4 OIL_WELLS_TOT

REAL*4 CONV_WELLS_TOT

REAL*4 TIGHT_WELLS_TOT

REAL*4 SHALE_WELLS_TOT

REAL*4 CBM_WELLS_TOT

! 1 2 3 4 5 6 7 8 

9 10

! EM4 TRACK -- keep here

DATA REG_CNST /0.165,0.250,0.187,0.147,0.178,0.235,0.191,0.174,0.169,0.175, & 

! AEO2002: P0=f(PGASLAG,WOP) change in ngtdm too

0.176,0.154,0.167,0.130,0.144,0.144,0.166,0.165,0.185,0.194,0.154/ 

! change in ngtdm too

DATA REG_CNST1 

/0.000000,1.22073,0.944568,0.644145,0.848594,1.22073,0.917775,0.839626,0.799027,0.818277,&

! same form as AEO2002

0.837841,0.667143,0.760292,0.00000,0.63307,0.633293,0.842891,0.000000,0.873371,1.040223,& 

! parameters reestimated

0.427865/ 

! 9/07/02

DATA REG_CNST2 

/-1.00000,-2.60565,-1.90727,-2.63350,-2.82434,-2.96152,-2.69612,-2.17580,-1.78278,-2.08644

, & ! Kevin's supply curve

-2.08877,-2.57941,-2.01510,-1.00000,-1.70728,-2.62790,-2.28963,-1.00000,-1.58386,-2.97082,

& ! August 2002

-1.00000/

DATA REG_CNST3 

/0.00000,6.30131,5.11757,5.83751,6.42938,7.04815,6.50180,5.24769,4.73239,5.21296,& ! 

P0=f(PR)

5.28422,6.06245,5.33154,0.00000,4.43217,6.04844,4.99544,0.00000,4.29734,6.19401,& ! 

7/06/05

5.51554/

DATA REG_CNST4 

/0.00000,6.12480,5.01729,5.85840,6.49504,6.84805,6.30017,5.25215,4.57664,5.01917,& ! 
P0=f(PR)

5.12463,6.00357,4.87346,0.00000,4.34634,6.13117,4.88606,0.00000,4.19316,6.21324,& ! 

7/06/05

5.51554/

DATA REG_CNST5 

/0.00000,4.69550,3.56578,4.43286,5.08061,5.43386,4.87937,3.80729,3.11726,3.57019,& ! 

P0=f(PR)

3.67787,4.58168,3.42322,0.00000,2.88471,4.71196,3.43140,0.00000,2.72364,4.78780,& ! 

7/06/05

4.08533/

DATA REG_CNST6 

/0.000000,-11.9200,-12.0374,-12.0671,-12.4173,-11.8249,-12.0920,-12.0038,-11.6418,-11.7450

,&

-11.8647,-11.7754,-12.9530,0.000000,-12.1479,-11.8890,-12.1491,0.000000,-11.7204,-12.4344,

&

-11.7829/

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

QSHFT= 0.0 ! temp code (not used now)

! SET REPLACEMENT RATE AND UNCONVENTIONAL GAS SHARE

IF (MODYR.GT.EHISYR) THEN

L48_PRD = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1) 

&

+ oogqngrep(4,curiyr-1) + oogqngrep(6,curiyr-1))

L48_RA = 0.

DO R=1,20

L48_RA = L48_RA + ZOGRADNGLAG1(r)

ENDDO

REPRATE = L48_RA / L48_PRD

UGRSHR = (oogqngrep(1,curiyr-1) + oogqngrep(2,curiyr-1) + oogqngrep(3,curiyr-1)) 

&

/ L48_PRD

onconvSHR = oogqngrep(4,curiyr-1) / L48_PRD

UGRRESSHRLAG = (oOGNGRSV(1,curiyr-1)+oOGNGRSV(2,curiyr-1)+oOGNGRSV(3,curiyr-1)) &

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

UGRRESSHR = (oOGNGRSV(1,curiyr)+oOGNGRSV(2,curiyr)+oOGNGRSV(3,curiyr)) &

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

IF (MODYR.EQ.EHISYR+1) THEN

HDDLAG = 4524 ! HDD from 9/2009 STEO

HDD = 4475.

! OEXSPEND(1,curiyr) = 1288.

! OEXSPEND(2,curiyr) = 67555752.

ELSEIF (MODYR.EQ.EHISYR+2) THEN

HDDLAG = HDD

HDD = 4478.

! OEXSPEND(1,curiyr) = 1204.

! OEXSPEND(2,curiyr) = 59013208.

ELSE

HDDLAG = HDD

HDD = 4237.

ENDIF

ELSE

REPRATE = 0.

UGRSHR = 0.

ENDIF

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

IVREG=VNODES(IREG)

NREG = MAP_NG(IREG)

IF(IREG.EQ.SNODES-lSNODES-3) NREG=13

PERCNT = PCTLP(NREG) * SCALE_LP(MODYR)

IF (MODYR .LE. EHISYR) THEN

XQBASE = QSUP(IREG) / (1.-PERCNT) ! w/ L&P

ELSE

XQBASE = ZOGRESNG(IREG) * ZOGPRRNG(IREG) ! w/ L*P

ENDIF

! EPA CODE MODIFICATION FOR RIA

NG_REDUCT_NEW = 0

OIL_WELLS_TOT = 0

CONV_WELLS_TOT = 0

TIGHT_WELLS_TOT = 0

SHALE_WELLS_TOT = 0

CBM_WELLS_TOT = 0

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

! NUMBER OF WELLS OF EACH TYPE

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

REFERENCE CASE MODEL IN 2020

U_PROD_CONV(1)=0.0000

U_PROD_CONV(2)=0.0455

U_PROD_CONV(3)=0.0085

U_PROD_CONV(4)=0.0702

U_PROD_CONV(5)=0.0041

U_PROD_CONV(6)=0.0000

U_PROD_CONV(7)=0.0040

U_PROD_CONV(8)=0.0446

U_PROD_CONV(9)=0.3448

U_PROD_CONV(10)=0.2801

U_PROD_CONV(11)=0.0372

U_PROD_CONV(12)=0.0776

U_PROD_CONV(13)=0.0000

U_PROD_CONV(14)=0.0000

U_PROD_CONV(15)=0.0234

U_PROD_CONV(16)=0.0463

U_PROD_CONV(17)=0.0136

U_PROD_TIGHT(1)=0.0000
U_PROD_TIGHT(2)=0.0008

U_PROD_TIGHT(3)=0.0055

U_PROD_TIGHT(4)=0.0002

U_PROD_TIGHT(5)=0.0025

U_PROD_TIGHT(6)=0.0000

U_PROD_TIGHT(7)=0.0043

U_PROD_TIGHT(8)=0.0006

U_PROD_TIGHT(9)=0.2017

U_PROD_TIGHT(10)=0.1040

U_PROD_TIGHT(11)=0.1209

U_PROD_TIGHT(12)=0.4183

U_PROD_TIGHT(13)=0.0000

U_PROD_TIGHT(14)=0.0000

U_PROD_TIGHT(15)=0.0163

U_PROD_TIGHT(16)=0.1248

U_PROD_TIGHT(17)=0.0000

U_PROD_SHALE(1)=0.0000

U_PROD_SHALE(2)=0.3385

U_PROD_SHALE(3)=0.0077

U_PROD_SHALE(4)=0.0000

U_PROD_SHALE(5)=0.0000

U_PROD_SHALE(6)=0.0246

U_PROD_SHALE(7)=0.0011

U_PROD_SHALE(8)=0.0000

U_PROD_SHALE(9)=0.3616

U_PROD_SHALE(10)=0.1470

U_PROD_SHALE(11)=0.1163

U_PROD_SHALE(12)=0.0031

U_PROD_SHALE(13)=0.0000

U_PROD_SHALE(14)=0.0000

U_PROD_SHALE(15)=0.0001

U_PROD_SHALE(16)=0.0000

U_PROD_SHALE(17)=0.0000

U_PROD_CBM(1)=0.0000

U_PROD_CBM(2)=0.0000

U_PROD_CBM(3)=0.0000

U_PROD_CBM(4)=0.0004

U_PROD_CBM(5)=0.0002

U_PROD_CBM(6)=0.0181

U_PROD_CBM(7)=0.0000

U_PROD_CBM(8)=0.0494

U_PROD_CBM(9)=0.0081

U_PROD_CBM(10)=0.0242

U_PROD_CBM(11)=0.0151

U_PROD_CBM(12)=0.8543

U_PROD_CBM(13)=0.0000

U_PROD_CBM(14)=0.0000

U_PROD_CBM(15)=0.0144

U_PROD_CBM(16)=0.0160

U_PROD_CBM(17)=0.0000

! ESTIMATES AND DISTRIBUTES ESTIMATES OF CAPTURED GAS (IN BCF) ACROSS WELL TYPES AND 

REGION

NG_REDUCT_NEW = (0.000019 * OIL_WELLS_TOT * U_PROD_SHALE(IREG) &

+ 0.000136 * CONV_WELLS_TOT * U_PROD_CONV(IREG) &

+ 0.000136 * TIGHT_WELLS_TOT * U_PROD_TIGHT(IREG) &

+ 0.000136 * SHALE_WELLS_TOT * U_PROD_SHALE(IREG) &

+ 0.000136 * CBM_WELLS_TOT * U_PROD_CBM(IREG)

! ADDS NATURAL GAS RECOVERED BE NEW SOURCES

XQBASE = NG_REDUCT_NEW + XQBASE

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

XPBASE = ZWPRLAG(IREG)

ELSEIF (SUPCRV.EQ.10) THEN

ICNT = 0

XPBASE = 0.0

DO J=1,IROLL

IF (ZWPROLL(IREG,J).GT.0.001) THEN

ICNT = ICNT + 1

XPBASE = XPBASE + ZWPROLL(IREG,J)

ENDIF

ENDDO

IF (ICNT.NE.0 .AND. MODYR.GT.LHISYR) THEN

XPBASE = XPBASE / REAL(ICNT)

ELSE

XPBASE = ZWPRLAG(IREG)

ENDIF

ELSEIF (SUPCRV.EQ.3) THEN

XPBASE = REG_CNST(IVREG) + (0.686*ZWPRLAG(IREG)) + (0.024*oIT_WOP(CURIYR,1)) - 

ZOGTAXPREM(IREG)

ELSEIF (SUPCRV.EQ.4) THEN

XPBASE = exp(-24.2580) * UGRRESSHR**1.62970 * oEXSPEND(1,curiyr-1)**0.066852 * 

HDD**2.22467 &

* ZWPRLAG(IREG)**0.527302 * exp(-24.2580*(-0.527302)) * 

UGRRESSHRLAG**(-0.527302*1.62970) &

* oEXSPEND(1,curiyr-2)**(-0.527302*0.066852) * HDD**(-0.527302*2.22467)

ELSEIF (SUPCRV.EQ.5) THEN

XPBASE = exp(-16.4735) * UGRRESSHR**1.16172 * oEXSPEND(1,curiyr-1)**0.072937 * 

HDD**1.49735 &

* ZWPRLAG(IREG)**0.317304 * exp(-16.4735*(-0.317304)) * 

UGRRESSHRLAG**(-0.317304*1.16172) &

* oEXSPEND(1,curiyr-2)**(-0.317304*0.072937) * HDD**(-0.317304*1.49735)

ELSEIF (SUPCRV.EQ.6) THEN ! AEO2010

if (zogresng(ireg).gt.0.) THEN

A1 = -10.6700 ! constant

B4 = -0.014253 ! BOY res

B1 = 0.633804 ! ugrresshr

B2 = 0.190494 ! average drill cost

B3 = 0.882912 ! HDD

B5 = 0.279016 ! WOP

RHO = 0.398350

XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 &

* ZOGRESNG(IREG)**(B4) &

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

* exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &

* (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &

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

* oIT_WOP(CURIYR-1,1)**(-RHO*B5) &

* 1.00000

ELSE

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

ENDIF

ELSEIF (SUPCRV.EQ.7) THEN

if (zogresng(ireg).gt.0.) THEN

A1 = -0.298040 ! constant

B4 = 0. ! BOY res

B1 = 0. ! ugrresshr

B2 = 0.403666 ! average cost per mcf

B3 = 0. ! HDD

B5 = 0.311518 ! WOP

RHO = 0.504134

XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 &

* ZOGRESNG(IREG)**(B4) &

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

* exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &

* (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &
* ZOGRESNGLAG1(IREG)**(-RHO*B4) &

* oIT_WOP(CURIYR-1,1)**(-RHO*B5) &

* 1.01076

ELSE

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

ENDIF

ELSEIF (SUPCRV.EQ.8) THEN

if (zogresng(ireg).gt.0.) THEN

A1 = -1.46449 ! constant

B4 = 0. ! BOY res

B1 = 0. ! ugrresshr

B2 = 0.121770 ! average drill cost per reserve additions

B3 = 0. ! HDD

B5 = 0.544238 ! WOP

RHO = 0.626528

XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(1,curiyr))**B2 * HDD**B3 &

* ZOGRESNG(IREG)**(B4) &

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

* exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &

* (oEXSPEND(1,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &

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

* oIT_WOP(CURIYR-1,1)**(-RHO*B5) &

* 1.00303

ELSE

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

ENDIF

ELSEIF (SUPCRV.EQ.9) THEN

if (zogresng(ireg).gt.0.) THEN

A1 = 0.547003 ! constant

B4 = 0. ! BOY res

B1 = 0. ! ugrresshr

B2 = 0.637656 ! average cost per mcf

B3 = 0. ! HDD

B5 = 0. ! WOP

RHO = 0.379721

XPBASE = exp(A1) * UGRRESSHR**B1 * (oEXSPEND(3,curiyr))**B2 * HDD**B3 &

* ZOGRESNG(IREG)**(B4) &

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

* exp(A1*(-RHO)) * UGRRESSHRLAG**(-RHO*B1) &

* (oEXSPEND(3,curiyr-1))**(-RHO*B2) * HDDLAG**(-RHO*B3) &

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

* oIT_WOP(CURIYR-1,1)**(-RHO*B5) &

* 1.02188

ELSE

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

ENDIF

ELSEIF (SUPCRV.EQ.21) THEN

IF (MODYR.LE.2006) THEN ! steo?

IF (SUPTYPE(IREG).LE.9) THEN

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

0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))

ELSE

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

ENDIF

ELSE

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

0.1E-03*(ZOGRESNG(IREG)-ZOGRESNGLAG1(IREG))

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

ENDIF

ELSEIF (SUPCRV.EQ.8) THEN

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

* ZWPRLAG(IREG)**0.339752 * exp(-2.88475*(-0.339752)) * 

UGRRESSHRLAG**(-0.339752*0.749417) &

* oIT_WOP(CURIYR-1,1)**(-0.339752*0.325610)

ELSEIF (SUPCRV.EQ.9) THEN
! IF (ZOGRESNG(IREG).GT.0.0) THEN

! XPBASE = ZOGRESNG(IREG)**-0.047340 * oIT_WOP(CURIYR,1)**0.136745 

*(UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432 &

! * ZWPRLAG(IREG)**0.277866 * ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340) &

! * oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745) * 

(UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432)

!

! Z1 = ZOGRESNG(IREG)**-0.047340

! Z2 = oIT_WOP(CURIYR,1)**0.136745

! Z3 = (UCAPCCU(MNUMNR,CURIYR)+UCAPCCN(MNUMNR,CURIYR))**0.231432

! Z4 = ZWPRLAG(IREG)**0.277866

! Z5 = ZOGRESNGLAG1(IREG)**(-0.277866*-0.047340)

! Z6 = oIT_WOP(CURIYR-1,1)**(-0.277866*0.136745)

! Z7 = (UCAPCCU(MNUMNR,CURIYR-1)+UCAPCCN(MNUMNR,CURIYR-1))**(-0.277866*0.231432)

! XPBASE = Z1 * Z2 * Z3 * Z4 * Z5 * Z6 * Z7

! ELSE

XPBASE = ZWPRLAG(IREG)

! ENDIF

ENDIF

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

IF (SUPCRV.NE.2) THEN !!!!!!! supply curve type 1 !!!!!!

! ALL OTHER NG PRODUCTION

FIXSUP = ZOGCCAPPRD(IREG) * (1.-PERCNT)

AQBASE = XQBASE * (1. - PARM_SUPCRV3)

BQBASE = XQBASE * (1. + PARM_SUPCRV3)

APBASE = XPBASE * (1.- (PARM_SUPCRV3 /PARM_SUPELAS(3)))

BPBASE = XPBASE * (1.+ (PARM_SUPCRV3 /PARM_SUPELAS(3)))

IF (PARM_SUPCRV5 .EQ. 0.0) THEN ! set 5-tier = 3-tier

PARM_SUPELAS(1) = PARM_SUPELAS(2)

PARM_SUPELAS(5) = PARM_SUPELAS(4)

ENDIF

CQBASE = AQBASE * (1. - PARM_SUPCRV5)

DQBASE = BQBASE * (1. + PARM_SUPCRV5)

CPBASE = APBASE * (1.- (PARM_SUPCRV5 /PARM_SUPELAS(2)))

DPBASE = BPBASE * (1.+ (PARM_SUPCRV5 /PARM_SUPELAS(4)))

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

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

! THREE/FIVE TIER METHOD

IF (INVAL.EQ.'P') THEN

IF (VALUE .LE. CPBASE) THEN

QBASE = CQBASE

PBASE = CPBASE

ELAS = PARM_SUPELAS(1)

ELSE IF (VALUE .LE. APBASE) THEN

QBASE = AQBASE

PBASE = APBASE

ELAS = PARM_SUPELAS(2)

ELSE IF (VALUE .GE. DPBASE) THEN

QBASE = DQBASE

PBASE = DPBASE

ELAS = PARM_SUPELAS(5)

ELSE IF (VALUE .GE. BPBASE) THEN

QBASE = BQBASE

PBASE = BPBASE

ELAS = PARM_SUPELAS(4)

ELSE

QBASE = XQBASE

PBASE = XPBASE
ELAS = PARM_SUPELAS(3)

END IF

NGSUP_PR = (1.-PERCNT) * QBASE * &

(1.+(ELAS*(VALUE-PBASE)/PBASE)) + QSHFT ! temp code

! * (1.+(ELAS*(VALUE-PBASE)/PBASE))

NGSUP_PR = AMAX1(NGSUP_PR,MIN_NA) ! w/o L&P

NGSUP_PR = FIXSUP + NGSUP_PR

NGSUP_PR = AMAX1(NGSUP_PR,0.0)

END IF

! THREE TIER METHOD FOR QUANTITIES

IF (INVAL.EQ.'Q') THEN

IF (XQBASE.GT.0.0) THEN

! QVAR = (VALUE - FIXSUP) / (1.-PERCNT) ! w/ L&P

QVAR = (VALUE - FIXSUP+QSHFT) / (1.-PERCNT) ! temp code (QSHFT)

IF (QVAR .LE. CQBASE) THEN

QBASE = CQBASE

PBASE = CPBASE

ELAS = PARM_SUPELAS(1)

ELSE IF (QVAR .LE. AQBASE) THEN

QBASE = AQBASE

PBASE = APBASE

ELAS = PARM_SUPELAS(2)

ELSE IF (QVAR .GE. DQBASE) THEN

QBASE = DQBASE

PBASE = DPBASE

ELAS = PARM_SUPELAS(5)

ELSE IF (QVAR .GE. BQBASE) THEN

QBASE = BQBASE

PBASE = BPBASE

ELAS = PARM_SUPELAS(4)

ELSE

QBASE = XQBASE

PBASE = XPBASE

ELAS = PARM_SUPELAS(3)

END IF

NGSUP_PR = PBASE * (((1./ELAS)*(QVAR-QBASE)/QBASE) + 1.)

ELSE

NGSUP_PR = XPBASE

END IF

IF (NGSUP_PR .LE. 0.0) THEN

WRITE(NGUNIT,20) CURIYR,CURITR,IREG,NGSUP_PR,VALUE,XQBASE

NGSUP_PR = 0.10 ! SET TO VERY LOW PRICE, BUT NOT NEGATIVE

ENDIF

END IF

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

ELSE IF(SUPCRV .EQ. 2) THEN !!!!!!! supply curve type 2 !!!!!!

! NEW METHOD PER KEVIN FORBES AUGUST 2002

! IF (IREG.EQ.21) THEN

IF (SUPTYPE(IREG).GE.10) THEN

IF (CURIYR.LE.1) THEN

NGSUP_PR = ZWPRLAG(IREG)

ELSE

! EM4 TRACK -- keep here

CNC = -3.70634

CNRHO = 0.619602

CNB1 = 0.325236

CNDL = (0.9184/0.7758)*1.2085 ! convert us87$ to cn92$

CNPRLAG = oOGCNQPRD(NG,CURIYR-1) / oOGRESCAN(NG,CURIYR-1)

TMPCAN = EXP(CNC*(1.-CNRHO))*(CNPRLAG/(1.-CNPRLAG))**CNRHO &

* oOGCNPPRD(NG,CURIYR-1)**(-1.*CNRHO*CNB1)

IF (INVAL.EQ.'Q') THEN

NGSUP_PR = (( (VALUE/oOGRESCAN(NG,CURIYR)) / &
(TMPCAN * (1.- (VALUE/oOGRESCAN(NG,CURIYR)))) )**(1/CNB1))/CNDL

ENDIF

IF (INVAL.EQ.'P') THEN

NGSUP_PR = oOGRESCAN(NG,CURIYR) &

* (TMPCAN * (VALUE*CNDL)**CNB1) / &

(1. + (TMPCAN * (VALUE*CNDL)**CNB1))

ENDIF

ENDIF

ELSE

! EM4 TRACK -- keep here

BETA1 = -0.297987

BETA2 = -0.349741

BETA3 = 0.150931

IF (ZOGRESNGLAG1(IREG).GT.0.0.AND.ZOGRESNGLAG2(IREG).GT.0.0) THEN

TMPUS = exp(REG_CNST2(IREG)) * (ZOGRADNGLAG1(IREG)/ZOGRESNGLAG1(IREG) + 

1)**beta1 &

* (ZOGRADNGLAG2(IREG)/ZOGRESNGLAG2(IREG) + 1)**beta2

ENDIF

IF (INVAL.EQ.'P') THEN

IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN

NGSUP_PR = 0.0

ELSE

NGSUP_PR = ZOGRESNG(IREG) &

* (TMPUS * VALUE**BETA3) / &

(1. + (TMPUS * VALUE**BETA3))

!CCC WRITE(6,*) ' PROD=', NGSUP_PR

ENDIF

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

!CCC WRITE(6,*) 'NGSUP_PR = ',NGSUP_PR,' RPSHIFT ',

!CCC * RPSHIFT(IREG)

!CCC WRITE(6,*) ' '

ENDIF

IF (INVAL.EQ.'Q') THEN

IF (CURIYR.LE.2.OR.VALUE.EQ.0.0 .OR. ZOGRESNG(IREG).EQ.0.0) THEN

NGSUP_PR = WPRLAG(IREG)

ELSE

NGSUP_PR = ((VALUE / ZOGRESNG(IREG)) &

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

WRITE(6,*) 'REGION= ',IREG,'YEAR=',CURIYR+1989

WRITE(6,*) 'TMPUS= ',TMPUS,' VALUE=',VALUE,'RES=',ZOGRESNG(IREG)

WRITE(6,*) 'PRICE = ',NGSUP_PR

WRITE(6,*) ' '

ENDIF

ENDIF

ENDIF ! temp: kevsup

ENDIF

! TRACE

! IF (IREG .EQ. SNODES) THEN ! canadian supply

! IF (INVAL.EQ.'Q') THEN

! WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS

! WRITE(NGOERR,15) AQBASE, XQBASE, BQBASE, QVAR, VALUE

! WRITE(NGOERR,16) APBASE, XPBASE, BPBASE, NGSUP_PR

! ELSE

! WRITE(NGOERR,14) MODYR,CURITR,INVAL,FIXSUP,PCTLP(NREG),ELAS

! WRITE(NGOERR,17) AQBASE, XQBASE, BQBASE, NGSUP_PR

! WRITE(NGOERR,18) APBASE, XPBASE, BPBASE, VALUE
! ENDIF

! ENDIF

14 FORMAT(1X,'NGSUP_PR: YR=',I4,' ITR=',I2,' INVAL=',A1, &

' FIXSUP=',F8.3,' PCTLP=',F8.3,' ELAS=',F8.4)

15 FORMAT(1X,'NGSUP_PR: AQ=',F8.1,' XQ=',F8.1,' BQ=',F8.1, &

' QVAR=',F8.1,' VALUE=',F8.1)

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

' SUPPR=',F8.4)

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

' SUPPR=',F8.1)

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

' VALUE=',F8.4)

IF (NGDBGITR(4,5)) THEN

WRITE(NGUNIT,10) CURIYR,CURITR,IREG,INVAL,VALUE,NGSUP_PR

WRITE(NGUNIT,11) XQBASE,ZOGRESNG(IREG), &

ZOGPRRNG(IREG)

END IF

10 FORMAT(1X,'NGSUP_PR: YR=',I3,' ITR=',I3,' REG(1-21)=',I4, &

' P OR Q= ',A1,' VALUE=',F15.4,' NGSUP_PR=',F15.4)

11 FORMAT(5X,'XQBASE=',F12.3,' ZOGRESNG=',F12.3,' ZOGPRRNG=', &

F12.3)

20 FORMAT(1X,'ATTN5 NGTDM, NGSUP_PRSUP_PR',I3,' ITR=',I3, &

' IREG(1-21)=',I4,' NGSUP_PR=',F10.3,' VALUE=',F10.1, &

' XQBASE=',F10.1)

RETURN

END

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

!

! USE FIXED AND VAR TARIFF INFO TO CALC ARC FEE

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! FUNCTIONS USED: NGPIPE_VARTAR

! NGSTR_VARTAR

!

! NOTES: MAY WANT TO ADD PR ADJUSTMENT FOR PIPE FUEL

!

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

SUBROUTINE NGSET_ARCFEE

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

INTEGER*4 L,A ! COUNTERS

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 STID ! STORAGE NODE ID (1-14)

INTEGER*4 XNET ! END-USE(1,3) VS SHR(1,2) NETWORK INDICATOR

REAL*4 NGSTR_VARTAR ! FUNCTION (from ptm)

REAL*4 NGPIPE_VARTAR ! FUNCTION (from ptm)

REAL*4 X1NGSTR_VARTAR ! FUNCTION (new)

REAL*4 XNGSTR_VARTAR !*FUNCTION (temp)

REAL*4 XNGPIPE_VARTAR !*FUNCTION (temp)
REAL*4 Q ! FLOW ALONG ARC W/IN PK OR OP SEASON

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

! TARIFF ON ALL PRIMARY ARCS

DO NET=1,NETWORK

DO A=1,NARCS

SRC = ARC_2NODE(A,1)

DEST= ARC_2NODE(A,2)

Q = FLOW(NET,A)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &

NGPIPE_VARTAR(NET,A,Q) ! FUNCTION

IF (NET .EQ. PKNET) THEN ! from ngptmX.f

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

!! NGPIPE_VARTAR(NET,A,Q) ! FUNCTION

ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)

ELSE ! from ngptmX.f

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

!! NGPIPE_VARTAR(NET,A,Q)

ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) ! from ngptmX.f

ENDIF

ELSE IF (SRC .GT. (TNODES+SNODES)) THEN ! STR ARCS

IF (NET .EQ. PKNET) THEN

STID = SRC - (TNODES+SNODES)

ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR) + &

X1NGSTR_VARTAR(STID,Q) ! FUNCTION

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

X1NGSTR_VARTAR(STID,Q) ! FUNCTION

ELSE

ARC_ENDFEE(NET,A) = 0.0

ARC_SHRFEE(NET,A) = 0.0

ENDIF

ELSE ! SUPPLY ARCS

ARC_ENDFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)

ARC_SHRFEE(NET,A) = ARC_FIXTAR(NET,A,MODYR)

ENDIF

ENDDO

ENDDO

RETURN

END

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

!

! PLACEHOLDER FOR PIPELINE VARIABLE TARIFF FUNCTION

!

! STATUS: UNDER CONSTRUCTION -- CHETHA WILL PROVIDE THIS ROUTINE

!

! CALLED BY: NGSET_ARCFEE

!

! NOTES: NEED TO TRANSLATE CAPACITY INTO PK (1/3) OR OP (2/3)

! AND USE PKUTZ & OPUTZ TO GET PR FOR EFFECTIVE FLOW

!

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

REAL FUNCTION XNGPIPE_VARTAR(XNET,A,SRC,DEST,Q)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 A ! ARC ID

INTEGER*4 SRC, DEST ! SOURCE, DEST NODES ON ARC

INTEGER*4 XNET ! NETWORK SIGNAL

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

! 2 = op for use w/ sharing price calc

! 1 = pk for use w/ end-use price calc

! 3 = op for use w/ end-use price calc

REAL*4 Q ! QUANTITY FLOWING ON NETWORK ARC

REAL*4 QA ! EQUIVALENT ANNUAL FLOW

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

IF (XNET .EQ. 1) THEN

QA = Q / PKSHR_YR

ELSE

QA = Q / (1.-PKSHR_YR)

ENDIF

! EM4 TRACK -- routine not called

IF ((SRC.EQ.2) .AND. (DEST.EQ.1)) THEN

XNGPIPE_VARTAR = (.023/413.)*QA

ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.2)) THEN

XNGPIPE_VARTAR = (.089/780.)*QA

ELSE IF ((SRC.EQ.3) .AND. (DEST.EQ.5)) THEN

XNGPIPE_VARTAR = (.133/890.)*QA

ELSE IF ((SRC.EQ.4) .AND. (DEST.EQ.3)) THEN

XNGPIPE_VARTAR = (.099/3106.)*QA

ELSE IF ((SRC.EQ.5) .AND. (DEST.EQ.2)) THEN

XNGPIPE_VARTAR = (.106/2496.)*QA

ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.3)) THEN

XNGPIPE_VARTAR = (.100/3525.)*QA

ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.5)) THEN

XNGPIPE_VARTAR = (.125/2664.)*QA

ELSE IF ((SRC.EQ.6) .AND. (DEST.EQ.10)) THEN

XNGPIPE_VARTAR = (.081/ 378.)*QA

ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.4)) THEN

XNGPIPE_VARTAR = (.145/2966.)*QA

ELSE IF ((SRC.EQ.7) .AND. (DEST.EQ.6)) THEN

XNGPIPE_VARTAR = (.108/7207.)*QA

ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.4)) THEN

XNGPIPE_VARTAR = (.074/ 950.)*QA

ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.7)) THEN

XNGPIPE_VARTAR = (.080/ 73.)*QA

ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.9)) THEN

XNGPIPE_VARTAR = (.020/ 621.)*QA

ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.11)) THEN

XNGPIPE_VARTAR = (.049/ 213.)*QA

ELSE IF ((SRC.EQ.8) .AND. (DEST.EQ.12)) THEN

XNGPIPE_VARTAR = (.063/1353.)*QA

ELSE IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN

XNGPIPE_VARTAR = (.023/ 413.)*QA

ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.7)) THEN

XNGPIPE_VARTAR = (.035/1110.)*QA

ELSE IF ((SRC.EQ.11) .AND. (DEST.EQ.12)) THEN

XNGPIPE_VARTAR = (.063/1353.)*QA

! ELSE IF ((SRC.EQ.13) .AND. (DEST.EQ.1)) THEN

! XNGPIPE_VARTAR = (.007/ 24.)*QA

! ELSE IF ((SRC.EQ.14) .AND. (DEST.EQ.2)) THEN

! XNGPIPE_VARTAR = (.007/ 150.)*QA

! ELSE IF ((SRC.EQ.16) .AND. (DEST.EQ.4)) THEN

! XNGPIPE_VARTAR = (.047/ 789.)*QA

! ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.4)) THEN

! XNGPIPE_VARTAR = (.059/ 993.)*QA

! ELSE IF ((SRC.EQ.17) .AND. (DEST.EQ.8)) THEN

! XNGPIPE_VARTAR = (.059/ 993.)*QA

! ELSE IF ((SRC.EQ.18) .AND. (DEST.EQ.9)) THEN

! XNGPIPE_VARTAR = (.310/ 301.)*QA

! ELSE IF ((SRC.EQ.19) .AND. (DEST.EQ.9)) THEN

! XNGPIPE_VARTAR = (.310/ 301.)*QA
! ELSE IF ((SRC.EQ.20) .AND. (DEST.EQ.7)) THEN

! XNGPIPE_VARTAR = (.142/ 16.)*QA

! ELSE IF ((SRC.EQ.21) .AND. (DEST.EQ.11)) THEN

! XNGPIPE_VARTAR = (.142/ 1.)*QA

! ELSE IF ((SRC.EQ.22) .AND. (DEST.EQ.12)) THEN

! XNGPIPE_VARTAR = (0.)*QA

! IF ((SRC.EQ.9) .AND. (DEST.EQ.12)) THEN

! IF (Q .LE. 413.) THEN

! XNGPIPE_VARTAR = .0000557*Q

! ELSEIF (Q .LE. 433.) THEN

! XNGPIPE_VARTAR = .0003*Q

! ELSEIF (Q .LE. 825.) THEN

! XNGPIPE_VARTAR = .0004796*Q

! ELSEIF (Q .LE. 1238.) THEN

! XNGPIPE_VARTAR = .00103*Q

! ELSE

! XNGPIPE_VARTAR = .00189*Q

! ENDIF

ELSE

XNGPIPE_VARTAR = .001

ENDIF

! XNGPIPE_VARTAR = .001 ! temp code

RETURN

END

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

!

! PLACEHOLDER FOR STORAGE VARIABLE TARIFF FUNCTION

!

! STATUS: UNDER CONSTRUCTION -- CHETHA WILL PROVIDE THIS ROUTINE

!

! CALLED BY: NGSET_ARCFEE

!

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

REAL FUNCTION XNGSTR_VARTAR(S,Q)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

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

REAL*4 Q ! QUANTITY FLOWING ON NETWORK ARC

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

XNGSTR_VARTAR = .001

RETURN

END

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

!

! MOVEMENT UP NETWORKS TO SET ARC AND NODE PRICES

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! QUESTIONS: HOW DO WE ADJUST PR FOR IMPACT FROM BKSTOP?

! --PERCENTAGE INCREASE IN NODE_SHRPR & NODE_ENDPR ??

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

!

SUBROUTINE NGUP_TREE(NET)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 L,A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

!CCC INTEGER*4 SHR_PRFLG ! FLAG INDICATING SHR_PR HAS BEEN INIT

INTEGER*4 I,J,K,N ! GENERIC INDICES

REAL*4 SHR_PR ! MARGINAL PR AT NODE ($/MCF)

REAL*4 PQ, Q ! HOLDS TOT USED TO CALC AVG PR

REAL*4 ARCPQ,ARCQ ! HOLDS TOT USED TO ADJ PR FOR PFUEL LOSS

REAL*4 TARCPQ,TARCQ ! HOLDS TOT USED TO AVG PR

REAL*4 HBSPOT(NETWORK,DNODES,FSPOTYR:LHISYR) ! BENCHMARK FACTOR FOR REGIONAL 

SPOT PRICES HISTORICAL

REAL*4 BSPOT(NETWORK,DNODES) ! BENCHMARK FACTOR FOR REGIONAL 

SPOT PRICES FORECAST

LOGICAL FIRST ! FIRST TIME CALLED IN FIRST FORECAST YEAR

DATA FIRST/.TRUE./

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

DO L=NPROC,1,-1 ! MOVE UP TREE

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

SHR_PR = 0.0

!CCC SHR_PRFLG = 0

PQ = 0.0

Q = 0.0

TARCPQ = 0.0

TARCQ = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

! BEFORE PIPEFUEL LOSS ADJ

ARC_ENDPR(NET,A) = NODE_ENDPR(NET,SRC) + ARC_ENDFEE(NET,A)

ARCPQ = ARC_ENDPR(NET,A) * FLOW(NET,A)

ARCQ = FLOW(NET,A) - ARC_PFUEL(NET,A)

! AFTER PIPEFUEL LOSS ADJ

IF (ARCQ .GT. 0.) THEN

ARC_ENDPR(NET,A) = ARCPQ / ARCQ ! AFTER PFUEL LOSS ADJ

ENDIF

PQ = PQ + ARCPQ

Q = Q + ARCQ

! BEFORE PIPEFUEL LOSS ADJ

ARC_SHRPR(NET,A) = NODE_SHRPR(NET,SRC) + ARC_SHRFEE(NET,A)

ARCPQ = ARC_SHRPR(NET,A) * FLOW(NET,A)

ARCQ = FLOW(NET,A) - ARC_PFUEL(NET,A)

! AFTER PIPEFUEL LOSS ADJ

IF (ARCQ .GT. 0.) THEN

ARC_SHRPR(NET,A) = ARCPQ / ARCQ ! AFTER PFUEL LOSS ADJ

ENDIF
! THE FOLLOWING REPLACES THE SUCCEEDING LINES OF CODE

! IF (FLOW_REM(NET,A) .GT. 0.0) THEN

TARCPQ = TARCPQ + ARCPQ

TARCQ = TARCQ + ARCQ

! ENDIF

!CCC IF (FLOW_REM(NET,A) .GT. 0.0) THEN

!CCC IF (SHR_PRFLG .EQ. 0) THEN

!CCC SHR_PR = ARC_SHRPR(NET,A)

!CCC SHR_PRFLG = 1

!CCC ELSE

!CCC SHR_PR = AMIN1(SHR_PR, ARC_SHRPR(NET,A))

!CCC ENDIF

!CCC ENDIF

ENDDO

! THE FOLLOWING 5 LINES ADDED W/ ABOVE ADDITION

IF (TARCQ .GT. 0.0) THEN

SHR_PR = TARCPQ / TARCQ

ELSE

SHR_PR = ARC_SHRPR(NET,ARC_1) ! CYCLE=1

DO A=ARC_1,ARC_2

SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A))

ENDDO

ENDIF

!CCC IF (SHR_PRFLG .EQ. 0) THEN ! EXPANSION ON ALL ARCS

!CCC SHR_PR = ARC_SHRPR(NET,ARC_1)

!CCC DO A=ARC_1,ARC_2

!CCC SHR_PR = AMAX1(SHR_PR, ARC_SHRPR(NET,A))

!CCC ENDDO

!CCC ENDIF

NODE_SHRPR(NET,DEST) = SHR_PR

IF (Q .GT. 0.0) THEN

NODE_ENDPR(NET,DEST) = PQ / Q

ELSE

NODE_ENDPR(NET,DEST) = SHR_PR

ENDIF

! ADJUST NODE PRICE FOR PR IMPACT FROM INTRAREG PFUEL

IF (INTRA_PFUEL(NET,DEST).GT.0.0) THEN

IF ((NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST)) .GT. 0.0) THEN

NODE_SHRPR(NET,DEST)=(NODE_SHRPR(NET,DEST)*NODE_DMD(NET,DEST)) / &

(NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST))

NODE_ENDPR(NET,DEST)=(NODE_ENDPR(NET,DEST)*NODE_DMD(NET,DEST)) / &

(NODE_DMD(NET,DEST)- INTRA_PFUEL(NET,DEST))

ELSE

write(6,'(A,I2,A,I2)') " Preventing infinity caused by NODE_DMD = INTRA_PFUEL 

at NET=",NET," DEST=",DEST

ENDIF

ENDIF

! BKSTOP PRICE PENALTY

IF (BKSTOP(NET,DEST) .GT. 0.) THEN

IF (RBKSTOP_FLG(NET,DEST) .EQ. 0) THEN

BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5

ENDIF

RBKSTOP_PADJ(NET,DEST) = RBKSTOP_PADJ(NET,DEST) + &

BKSTOP_PADJ(NET,DEST)

RBKSTOP_FLG(NET,DEST) = 1

ELSE

! IF (RBKSTOP_FLG(NET,DEST) .EQ. 1) THEN

! BKSTOP_PADJ(NET,DEST) = BKSTOP_PADJ(NET,DEST) *.5

! ENDIF

! RBKSTOP_PADJ(NET,DEST) = AMAX1(0.0,
! * (RBKSTOP_PADJ(NET,DEST) - BKSTOP_PADJ(NET,DEST)))

RBKSTOP_FLG(NET,DEST) = 0

ENDIF

! RBKSTOP_PADJ(NET,DEST) = 0.0 ! temp code

NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + &

RBKSTOP_PADJ(NET,DEST)

! NODE_ENDPR(NET,DEST) = NODE_ENDPR(NET,DEST) +

! + RBKSTOP_PADJ(NET,DEST)

! BENCHMARK TO HISTORICAL SPOT PRICES

IF (DEST.LE.DNODES .AND. MODYR.GE.FSPOTYR) THEN

IF (MODYR.LE.LHISYR) THEN

HBSPOT(NET,DEST,MODYR) = HNSPOT(NET,DEST,MODYR) - NODE_SHRPR(NET,DEST)

NODE_SHRPR(NET,DEST) = HNSPOT(NET,DEST,MODYR)

ELSE

IF (FIRST) THEN

BSPOT = 0.0

DO N=1,NETWORK

DO J=1,DNODES

DO K=FSPOTYR,LHISYR

BSPOT(N,J) = BSPOT(N,J) + HBSPOT(N,J,K)

ENDDO

BSPOT(N,J) = BSPOT(N,J) / REAL(LHISYR-FSPOTYR+1)

ENDDO

ENDDO

FIRST = .FALSE.

ENDIF

NODE_SHRPR(NET,DEST) = NODE_SHRPR(NET,DEST) + BSPOT(NET,DEST)

ENDIF

ENDIF

ENDDO

RETURN

END

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

!

! SET STORAGE PRICES FOR USE IN PK, BASED ON OP RESULTS

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

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

SUBROUTINE NGSET_STORPR

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 L,A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

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

DO L=1,NPROC ! LOOP OVER TRANSFER NODES

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)
DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .GT. (TNODES+SNODES)) THEN

NODE_SHRPR(PKNET,SRC) = NODE_SHRPR(OPNET,DEST)

NODE_ENDPR(PKNET,SRC) = NODE_ENDPR(OPNET,DEST)

ENDIF

ENDDO

ENDDO

RETURN

END

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

!

! SET INTRAREGIONAL FLOWS, CAPACITIES, AND TARIFFS

!

! STATUS:

!

! CALLED BY: NGTDM_ITM

!

! QUESTIONS:

!

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

SUBROUTINE NGSET_INTRAFLO

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'ngptmitm'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A ! COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

REAL*4 FAC(DNODES) ! SEASONAL SHARE FACTOR

REAL*4 PKNETDMD ! PK NET NODE DMD (W/O PIPEFUEL)

REAL*4 OPNETDMD ! OP NET NODE DMD (W/O PIPEFUEL)

REAL*4 NGPIPE_VARTAR ! PTM FUNCTION TO SET PIPE TARIFF

REAL*4 TEMP ! TEMP HOLD INTRAREG VARTAR

! --------

! DEFINE INTRAREGIONAL FLOWS, FLOW FACTOR, AND TARIFFS

! FLO_FAC = INTRA_FLO / NODE_DMD(W/O PF)

DO DEST=1,DNODES

DO NET=1,NETWORK

IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN

IF (NET .EQ. PKNET) THEN ! PEAK SEASON

PKNETDMD = NODE_DMD(PKNET,DEST)-PFUEL(PKNET,DEST)

OPNETDMD = NODE_DMD(OPNET,DEST)-PFUEL(OPNET,DEST)

FAC(DEST) = PKNETDMD / (PKNETDMD + OPNETDMD)

ELSE ! OFFPEAK SEASON

FAC(DEST) = 1. - FAC(DEST)

ENDIF

A = SNODE_2ARC(DEST,DEST)

INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR)

HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / &

(NODE_DMD(NET,DEST) - PFUEL(NET,DEST))

! 

write(69,*)'intra',modyr,dest,net,INTRA_FLO(NET,DEST,MODYR),SAFLOW(A,MODYR),NODE_DMD(NET,D

EST),PFUEL(NET,DEST)

ELSE
A = SNODE_2ARC(DEST,DEST)

INTRA_FLO(NET,DEST,MODYR) = FLO_FAC(NET,DEST) * &

(NODE_DMD(NET,DEST) - PFUEL(NET,DEST))

IF (NET .EQ. PKNET) THEN

SAFLOW(A,MODYR) = INTRA_FLO(PKNET,DEST,MODYR)

ELSE

SAFLOW(A,MODYR) = SAFLOW(A,MODYR) + &

INTRA_FLO(NET,DEST,MODYR)

ENDIF

ENDIF

!CCC TEMP = INTRAREG_TAR(NET,DEST) - INTRAREG_FIXTAR(NET,DEST)

!CCC WRITE(4,1000) MODYR,NET,DEST,INTRAREG_FIXTAR(NET,DEST),

!CCC * TEMP,INTRAREG_TAR(NET,DEST),INTRA_FLO(NET,DEST,MODYR)

!1000 FORMAT(' INTRA ',I4,2I3,3F6.3,F10.2)

ENDDO

ENDDO

IF ((EHISYR.EQ.LHISYR) .AND. (MODYR.EQ.LHISYR)) THEN

CALL HNGSET_CGPR

ELSE

DO DEST=1,DNODES

DO NET=1,NETWORK

INTRAREG_TAR(NET,DEST) = INTRAREG_FIXTAR(NET,DEST) + &

NGPIPE_VARTAR(NET,NARCS+DEST,INTRA_FLO(NET,DEST,MODYR)) ! PTM function

ENDDO

ENDDO

ENDIF

RETURN

END

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

!

! SET END-USE SECTOR PRICES BASED ON AVERAGE NODE PRICES

! AND HUB MARKUPS (PROVIDED BY DTM)

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! QUESTIONS: WHAT ABOUT LOSSES ALONG DISTRIBUTOR ARCS?

! DO NEW QUANTITIES NEED TO BE DEFINED HERE?

!

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

SUBROUTINE NGSET_SECPR

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngdtminc'

include 'ngcdmdinc'

include 'ngptmitm'

include 'ngsteoinc'

include 'ogglobal'

INTEGER*4 N ! DEMAND NODES

INTEGER*4 CENREG ! CENSUS DIVISION

INTEGER*4 J ! COUNTER

INTEGER*4 NET ! REPRESENTS PK/OP NETWORKS

INTEGER*4 SEC ! SECTOR ID

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

REAL*4 PQ_F(DNODES) ! PR * QTY FOR FIRM UTIL

REAL*4 PQ_I(DNODES) ! PR * QTY FOR INTRP UTIL

REAL*4 Q_F(DNODES) ! QTY FOR FIRM UTIL

REAL*4 Q_I(DNODES) ! QTY FOR INTRP UTIL

REAL*4 NGSET_INTRATAR! FUNCTION TO SET INTRAREG TARIFFS

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

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

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES

DO NET=1,NETWORK ! LOOP OVER PK/OP NETWORKS

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

INTRAST_TAR(N) + CGBENCH(NET,N)

DO SEC=1,DSEC-1 ! NONUTILITY (F TRANS WILL BE REPLACED)

! NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N) +

! * SCALE_FPR(MODYR)

! NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N) +

! * SCALE_IPR(MODYR)

NGPR_SF(NET,SEC,N) = CGPR(NET,N) + DTAR_SF(NET,SEC,N)

NGPR_SI(NET,SEC,N) = CGPR(NET,N) + DTAR_SI(NET,SEC,N)

ENDDO

! FLEET AND PERSONAL VEHICLES

SEC=4

! NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N) +

! * SCALE_FPR(MODYR)

! NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N) +

! * SCALE_FPR(MODYR)

NGPR_TRFV_SF(NET,N) = CGPR(NET,N) + DTAR_TRFV_SF(NET,N)

NGPR_TRPV_SF(NET,N) = CGPR(NET,N) + DTAR_TRPV_SF(NET,N)

IF (OPTELS.EQ.0) THEN

NGPR_TRFV_SL(NET,N) = CGPR(NET,N) + DTAR_TRFV_SL(NET,N)

NGPR_TRPV_SL(NET,N) = CGPR(NET,N) + DTAR_TRPV_SL(NET,N)

ELSE

NGPR_TRFV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRFV_SL(NET,N)

NGPR_TRPV_SL(NET,N) = NODE_SHRPR(NET,N) + DTAR_TRPV_SL(NET,N)

ENDIF

! assume ship prices same as for vehicles except no state taxes

! assume rail prices same as for vehicles except no taxes and discount on LNG

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

(oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

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

(oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_TRLN_SS(NET,N) = NGPR_TRFV_SL(NET,N) - (STAXL(N) / 

(oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_TRCN_SS(NET,N) = NGPR_TRFV_SF(NET,N) - (STAX(N) / 

(oMC_PCWGDP(CURIYR)/oMC_PCWGDP(-2)))

NGPR_SF(NET,SEC,N) = &

( (NGPR_TRFV_SF(NET,N) * BASQ_TRFV_SF(NET,N)) + &

(NGPR_TRPV_SF(NET,N) * BASQ_TRPV_SF(NET,N)) + &

(NGPR_TRFV_SL(NET,N) * BASQ_TRFV_SL(NET,N)) + &

(NGPR_TRPV_SL(NET,N) * BASQ_TRPV_SL(NET,N)) + &

(NGPR_TRLN_SR(NET,N) * BASQ_TRLN_SR(NET,N)) + &

(NGPR_TRCN_SR(NET,N) * BASQ_TRCN_SR(NET,N)) + &

(NGPR_TRLN_SS(NET,N) * BASQ_TRLN_SS(NET,N)) + &

(NGPR_TRCN_SS(NET,N) * BASQ_TRCN_SS(NET,N)) ) / &

(BASQ_TRFV_SF(NET,N) + BASQ_TRPV_SF(NET,N) + &

BASQ_TRFV_SL(NET,N) + BASQ_TRPV_SL(NET,N) + &

BASQ_TRLN_SR(NET,N) + BASQ_TRCN_SR(NET,N) + &

BASQ_TRLN_SS(NET,N) + BASQ_TRCN_SS(NET,N))

ENDDO
ENDDO

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

DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16

N = EMMSUB_NG(J) ! NGTDM REGION 1-12

DO NET=1,NETWORK

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

! * SCALE_FPR(MODYR)

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

! * SCALE_IPR(MODYR)

IF (OPTELS.EQ.0) THEN

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

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

ELSE

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

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

ENDIF

! temp set f * i to average

IF ((BASUQTY_SF(NET,J)+BASUQTY_SI(NET,J)) .GT. 0.0000001) THEN

NGUPR_SF(NET,J) = ((NGUPR_SF(NET,J)*BASUQTY_SF(NET,J)) + &

(NGUPR_SI(NET,J)*BASUQTY_SI(NET,J))) / &

(BASUQTY_SF(NET,J) + BASUQTY_SI(NET,J))

ELSE

NGUPR_SF(NET,J) = 2.0

ENDIF

NGUPR_SI(NET,J) = NGUPR_SF(NET,J)

ENDDO

ENDDO

! SET STEO SCALE FACTOR AND ADJUST END-USE PRICES

IF (MODYR .GT. EHISYR) THEN

CALL NGSTEO_BENCHENDPR

DO NET=1,NETWORK

DO N=1,DNODES

DO SEC=1,DSEC-1

NGPR_SF(NET,SEC,N) = NGPR_SF(NET,SEC,N) + SCALE_FPR(SEC,MODYR)

NGPR_SI(NET,SEC,N) = NGPR_SI(NET,SEC,N) + SCALE_IPR(SEC,MODYR)

ENDDO

SEC=4 ! TRANS

NGPR_TRFV_SF(NET,N) = NGPR_TRFV_SF(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRPV_SF(NET,N) = NGPR_TRPV_SF(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRFV_SL(NET,N) = NGPR_TRFV_SL(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRPV_SL(NET,N) = NGPR_TRPV_SL(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRLN_SR(NET,N) = NGPR_TRLN_SR(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRCN_SR(NET,N) = NGPR_TRCN_SR(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRLN_SS(NET,N) = NGPR_TRLN_SS(NET,N) + SCALE_FPR(SEC,MODYR)

NGPR_TRCN_SS(NET,N) = NGPR_TRCN_SS(NET,N) + SCALE_FPR(SEC,MODYR)

ENDDO

SEC = 5 ! UTILITY

DO J=1,NNGEM-1

NGUPR_SF(NET,J) = NGUPR_SF(NET,J) + SCALE_FPR(SEC,MODYR)

NGUPR_SI(NET,J) = NGUPR_SI(NET,J) + SCALE_IPR(SEC,MODYR)

ENDDO

ENDDO

ENDIF

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

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES

DO SEC=1,DSEC-1 ! NONUTILITY (F TRANS WILL BE REPLACED)
NGPR_F(SEC,N) = PKSHR_DMD(SEC,N) * NGPR_SF(PKNET,SEC,N) + &

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

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

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

ENDDO

SEC=4 ! FLEET AND PERSONAL VEHICLES

NGPR_TRFV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SF(PKNET,N) + &

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

NGPR_TRPV_F(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SF(PKNET,N) + &

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

NGPR_TRFV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRFV_SL(PKNET,N) + &

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

NGPR_TRPV_L(N) = PKSHR_DMD(SEC,N) * NGPR_TRPV_SL(PKNET,N) + &

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

NGPR_TRLN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SR(PKNET,N) + &

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

NGPR_TRCN_R(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SR(PKNET,N) + &

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

NGPR_TRLN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRLN_SS(PKNET,N) + &

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

NGPR_TRCN_S(N) = PKSHR_DMD(SEC,N) * NGPR_TRCN_SS(PKNET,N) + &

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

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

CENREG = NG_CENMAP(N) ! CENSUS DIVISION

! NGPR_TRPV_F(N) = AMAX1(NGPR_TRPV_F(N)+(oJNGTR(CURIYR)*oCFNGN(CURIYR)), &

! ((oPMGTR(CENREG,CURIYR)+oJMGTR(CURIYR))*oCFNGN(CURIYR))**PERMG) - &

! oJNGTR(CURIYR)*oCFNGN(CURIYR)

SEC=4 ! REPLACE F TRANS

NGPR_F(SEC,N) = ( (NGPR_TRFV_F(N) * BASQ_TRFV_F(N)) + &

(NGPR_TRPV_F(N) * BASQ_TRPV_F(N)) + &

(NGPR_TRFV_L(N) * BASQ_TRFV_L(N)) + &

(NGPR_TRPV_L(N) * BASQ_TRPV_L(N)) + &

(NGPR_TRLN_R(N) * BASQ_TRLN_R(N)) + &

(NGPR_TRCN_R(N) * BASQ_TRCN_R(N)) + &

(NGPR_TRLN_S(N) * BASQ_TRLN_S(N)) + &

(NGPR_TRCN_S(N) * BASQ_TRCN_S(N)) ) / &

(BASQ_TRFV_F(N) + BASQ_TRPV_F(N) + &

BASQ_TRFV_L(N) + BASQ_TRPV_L(N) + &

BASQ_TRLN_R(N) + BASQ_TRCN_R(N) + &

BASQ_TRLN_S(N) + BASQ_TRCN_S(N))

ENDDO ! END LOOP OVER REG 1-12

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

SEC=5

DO N=1,DNODES ! NGTDM DMD REGIONS

PQ_F(N) = 0.0 ! USED BY UTIL SEC=5

PQ_I(N) = 0.0 ! USED BY UTIL SEC=5

Q_F(N) = 0.0 ! USED BY UTIL SEC=5

Q_I(N) = 0.0 ! USED BY UTIL SEC=5

ENDDO

DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16

N = EMMSUB_NG(J) ! NGTDM REGION 1-12

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

(1.-PKSHR_UDMD_F(J)) * NGUPR_SF(OPNET,J)

NGUPR_I(J) = PKSHR_UDMD_I(J) * NGUPR_SI(PKNET,J) + &

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

PQ_F(N) = PQ_F(N) + NGUPR_F(J) * BASUQTY_F(J)

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

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

ENDDO

DO N=1,DNODES

NGPR_F(SEC,N) = PQ_F(N) / Q_F(N)

NGPR_I(SEC,N) = PQ_I(N) / Q_I(N)

ENDDO

RETURN

END

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

!

! RESET PREVIOUS DMD AND SUPPLY FOR CONV CHK NEXT CYCLE

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! FUNCTIONS USED: NGDMD_CRVF

! NGDMD_CRVI

!

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

SUBROUTINE NGSET_PREV

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

INTEGER*4 N ! DEMAND NODES

INTEGER*4 J ! COUNTER

INTEGER*4 S ! SUPPLY NODE ID

INTEGER*4 SEC ! SECTOR ID

REAL*4 NGDMD_CRVF ! FUNCTION: NONUTILITY DMD CRV

REAL*4 NGDMD_CRVI ! FUNCTION: NONUTILITY DMD CRV

REAL*4 NGUDMD_CRVF ! FUNCTION: UTILITY DMD CRV

REAL*4 NGUDMD_CRVI ! FUNCTION: UTILITY DMD CRV

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

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

IF (MODYR .GT. EHISYR) THEN

! ----

DO N=1,DNODES ! NGTDM DMD REGIONS

DO SEC=1,DSEC-1 ! DEMAND SECTORS

ZNGQTY_F(SEC,N) = 0.0

ZNGQTY_I(SEC,N) = 0.0

ENDDO

ENDDO

DO J=1,NNGEM-1

ZNGUQTY_F(J) = 0.0

ZNGUQTY_I(J) = 0.0

ENDDO

DO SEC=1,DSEC-1 ! NONUTILITY

DO N=1,DNODES

ZNGQTY_F(SEC,N) = &

NGDMD_CRVF(SEC,N,NGPR_F(SEC,N)) ! FUNCTION

ZNGQTY_I(SEC,N) = &

NGDMD_CRVI(SEC,N,NGPR_I(SEC,N)) ! FUNCTION
ENDDO

ENDDO

SEC = 5 ! UTILITY

DO J=1,NNGEM-1 ! UTILITY SUBREGIONS 1-16

N = EMMSUB_NG(J) ! NGTDM REGION

ZNGUQTY_F(J) = NGUDMD_CRVF(J,NGUPR_F(J)) ! FUNCTION

ZNGUQTY_I(J) = NGUDMD_CRVI(J,NGUPR_F(J)) ! FUNCTION

!CC ZNGQTY_F(SEC,N) = ZNGQTY_F(SEC,N) + ZNGUQTY_F(J)

!CC ZNGQTY_I(SEC,N) = ZNGQTY_I(SEC,N) + ZNGUQTY_I(J)

ENDDO

! ----

ENDIF

RETURN

END

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

!

! DEMAND CURVE FOR FIRM NONUTILITY SERVICE

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_PREV

!

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

REAL FUNCTION NGDMD_CRVF(SEC,REG,PR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 REG ! NODE ID

INTEGER*4 SEC ! SECTOR ID

REAL*4 PR ! PRICE ON DMD CURVE

REAL*4 Q0 ! BASE QTY (COMP) IN CURVE EQ.

REAL*4 P0 ! BASE PR IN CURVE EQ.

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

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

IF ( CURITR.EQ.1 .OR. CONST_DMD.EQ.1 .OR. &

SEC.EQ.4 .OR. PR.LE.0.0 .OR. P0.LE.0.0 ) THEN

NGDMD_CRVF = BASQTY_F(SEC,REG)

RETURN

ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASQTY_F(SEC,REG)

P0 = BASPR_F(SEC,REG)

NGDMD_CRVF = Q0 * ((PR / P0) ** NONU_ELAS_F(SEC))

RETURN

END

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

!

! DEMAND CURVE FOR INTERRUPTIBLE NONUTILITY SERVICE

!

! STATUS: PLACEHOLDER
!

! CALLED BY: NGSET_PREV

!

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

REAL FUNCTION NGDMD_CRVI(SEC,REG,PR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 REG ! NODE ID

INTEGER*4 SEC ! SECTOR ID

REAL*4 PR ! PRICE ON DMD CURVE

REAL*4 Q0 ! BASE QTY (COMP) IN CURVE EQ.

REAL*4 P0 ! BASE PR IN CURVE EQ.

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

! SET DMD = CONSTANT IF HIST YEARS -OR- TRANS SECTOR

IF ( CURITR.EQ.1 .OR. CONST_DMD.EQ.1 .OR. &

SEC.EQ.4 .OR. PR.LE.0.0 .OR. P0.LE.0.0 ) THEN

NGDMD_CRVI = BASQTY_I(SEC,REG)

RETURN

ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASQTY_I(SEC,REG)

P0 = BASPR_I(SEC,REG)

NGDMD_CRVI = Q0 * ((PR / P0) ** NONU_ELAS_I(SEC))

RETURN

END

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

!

! DEMAND CURVE FOR FIRM UTILITY SERVICE

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_PREV

!

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

REAL FUNCTION NGUDMD_CRVF(SREG,PR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 SREG ! SUBREGION ID

REAL*4 PR ! PRICE ON DMD CURVE

REAL*4 Q0 ! BASE QTY (COMP) IN CURVE EQ.

REAL*4 P0 ! BASE PR IN CURVE EQ.

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

! SET DMD = CONSTANT IF CURITR=1 -OR- HIST YEARS
IF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN

NGUDMD_CRVF = BASUQTY_F(SREG)

RETURN

ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASUQTY_F(SREG)

P0 = BASUPR_F(SREG)

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

RETURN

END

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

!

! DEMAND CURVE FOR INTERRUPTIBLE UTILITY SERVICE

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_PREV

!

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

REAL FUNCTION NGUDMD_CRVI(SREG,PR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 SREG ! SUBREGION ID

REAL*4 PR ! PRICE ON DMD CURVE

REAL*4 Q0 ! BASE QTY (COMP) IN CURVE EQ.

REAL*4 P0 ! BASE PR IN CURVE EQ.

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

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

IF ( (CURITR .EQ. 1) .OR. (CONST_DMD .EQ. 1) ) THEN

NGUDMD_CRVI = BASUQTY_I(SREG)

RETURN

ENDIF

! IF NONHISTORICAL YEARS PRODUCE DEMAND CURVE

Q0 = BASUQTY_I(SREG)

P0 = BASUPR_I(SREG)

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

RETURN

END

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

!

! SET BASPR AND BASUPR FOR USE BY DMD CURVE FUNCTIONS

!

! STATUS:

!

! CALLED BY: NGTDM_ITM (EVERY ITERATION)

!

! = = = = = = = = = = = = = = = = = = = = = = = = = = = =
SUBROUTINE NGITM_BASPR

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

INTEGER*4 N ! NODE ID

INTEGER*4 J ! SUBREGION ID

INTEGER*4 SEC ! SECTOR ID

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

DO SEC=1,DSEC-1

DO N=1,DNODES

BASPR_F(SEC,N) = NGPR_F(SEC,N)

BASPR_I(SEC,N) = NGPR_I(SEC,N)

ENDDO

ENDDO

DO J=1,NNGEM-1

BASUPR_F(J) = NGUPR_F(J)

BASUPR_I(J) = NGUPR_I(J)

ENDDO

RETURN

END

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

!

! SET ACTUAL/FINAL ARC CAPACITIES FOR HIST YEARS

! ACTPCAP

!

! STATUS: COMPLETE

!

! CALLED BY: HNGTDM_ITM

!

! FREQUENCY: EVERY NEMS ITERATION AND HIST YEAR

!

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

SUBROUTINE HNGSET_ACTPCAP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A ! ARC COUNTER

INTEGER*4 SRC ! SRC ID

INTEGER*4 DEST ! DEST ID

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

DO A=1,NARCS

SRC = ARC_2NODE(A,1)

DEST= ARC_2NODE(A,2)

ACTPCAP(A) = CURPCAP(A,MODYR)

ENDDO

RETURN

END

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

! SET ACTUAL/FINAL ARC CAPACITIES

! ACTPCAP

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! FREQUENCY: EVERY NEMS ITERATION AND YEAR

!

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

SUBROUTINE NGSET_ACTPCAP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 A ! ARC COUNTER

INTEGER*4 SRC ! SRC ID

INTEGER*4 DEST ! DEST ID

REAL*4 PKFAC ! ANNUAL TO PK SEASON CONVERSION

REAL*4 OPFAC ! ANNUAL TO OP SEASON CONVERSION

REAL*4 PK_CAP ! PK EQUIV CAP FOR FLORIDA

REAL*4 OP_CAP ! OP EQUIV CAP FOR FLORIDA

REAL*4 PCAP ! MAX CAP BETWEEN PK & OP EQUIV CAP

REAL*4 MAXPCAP17 ! TOTAL CAPACITY OUT OF NODE 17 (2 arcs)

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

MAXPCAP17=0.0

DO A=1,NARCS

SRC = ARC_2NODE(A,1)

DEST= ARC_2NODE(A,2)

IF ((SRC .EQ. 6) .AND. (DEST .EQ. 10)) THEN ! PIPE TO FLORIDA

PKFAC = PKSHR_YR * PKUTZ(A)

OPFAC = (1.-PKSHR_YR) * OPUTZ(A)

PK_CAP = FLOW(PKNET,A) / PKFAC

OP_CAP = FLOW(OPNET,A) / OPFAC

PCAP = AMAX1( PK_CAP, OP_CAP )

ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) )

ELSE IF(SRC .GT. (TNODES+SNODES)) THEN ! STORAGE ARCS

PCAP = FLOW(PKNET,A) / PKUTZ(A)

ACTPCAP(A) = AMAX1( PCAP, CURPCAP(A,MODYR) )

!-EM4 ACTPCAP(A) = AMIN1( ACTPCAP(A), MAXPCAP(PKNET,A) )

MAXPCAP(OPNET,A) = ACTPCAP(A)

ELSE

IF (SRC.EQ.17) THEN ! SUM ARCS LEAVING NODE 17

MAXPCAP17=MAXPCAP17+MAXPCAP(OPNET,A)

ENDIF

IF (DEST.EQ.17) THEN

MAXPCAP(OPNET,A) = AMAX1(MAXPCAP(OPNET,A),MAXPCAP17)

ENDIF

ACTPCAP(A) = MAXPCAP(OPNET,A)

ENDIF

ENDDO

RETURN

END
! = = = = = = = = = = = = = = = = = = = = = = = = = = = =

!

! PREPROCESSING ROUTINES:

! - CALL ROUTINE TO SET CONST DMD

! - CALL ROUTINE TO SET MAX CAPACITY

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

! FREQUENCY: EVERY NEMS ITERATION AND YEAR

!

! CALLS TO: NGSET_NODECDMD

! NGSET_MAXPCAP

! NGSET_ZOGVAR

!

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

SUBROUTINE NGITM_PRE

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngcdmdinc'

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

CALL NGSET_NODECDMD ! SET NODE_CDMD: CONST DMD & SUP

IF (CURITR .EQ. 1) THEN

CALL NGSET_ZOGVAR ! SET ZOG... VARIABLES FOR ITM USE

CALL NGSET_MAXPCAP ! SET MAX CAP ON ALL ARCS

ENDIF

RETURN

END

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

!

! SET CONST DMD AND SUPPLY NET TOTALS:

! NODE_CDMD

!

! STATUS: COMPLETE

!

! CALLED BY: NGITM_PRE

!

! FREQUENCY: EVERY ITERATION OF EVERY YEAR

!

! NOTES: ADGAS CHANGES EVERY NEMS ITERATION

! ALL OTHER CONST SUP/DMD CHANGE EACH YEAR

!

! INPUT VARIABLES:

! YEAR_CDMD(2,24)

! ZADGPRD(12)

!

! OUTPUT VARIABLES:

! NODE_CDMD(2,24)

!

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

SUBROUTINE NGSET_NODECDMD

IMPLICIT NONE

include 'parametr'

include 'ncntrl'
include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'ngdtminc'

include 'ogglobal'

INTEGER*4 L,A ! COUNTERS

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 N,M ! NODE ID

INTEGER*4 SRC, DEST !

INTEGER*4 I !

character*5 dum

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

! if(modyr.eq.1990.and.curitr.eq.1) OPEN(UNIT=69,FILE="ngdebg1.txt")

! if(modyr.eq.1990.and.curitr.eq.1) open(unit=68,file="ngdebg.txt")

DO NET=1,NETWORK

DO N=1,TNODES

NODE_CDMD(NET,N) = 0.0

MTH_CDMD(NET,N) = 0.0 ! peak month

ENDDO

ENDDO

CALL NGSET_ADSUP

CALL NGSET_FIXSUP ! mvd fr ngset_yearcdmd

! SECD FLOWS, CAN/MEX EXP, MEX IMP,

! TOTAL SUPLMT, LNG, DISC, ANGTS,

! SABLE ISLAND

IF (MODYR.GT.LHISYR .OR. CURITR .EQ. 1) THEN ! EVENTUALLY CHECK WHY HIST DIFF IF 

CALLED WHEN CURITR>1

CALL NGSET_YEARCDMD

ENDIF

! PUT INTO CONST DMD VARIABLE

DO NET=1,NETWORK

DO N=1,TNODES

NODE_CDMD(NET,N) = YEAR_CDMD(NET,N)

MTH_CDMD(NET,N) = MTHYR_CDMD(NET,N) ! peak month

ENDDO

ENDDO

! LNG IMPORTS

FIXSUPIP = 0.0

! added 7-1-07 fr previous version by Yelena

! LNG IMPORTS AND CONST ON/OFF SHORE ADGAS

!rmv yd1 see above CALL NGSET_ADSUP

DO I=1,SNODES

N=MAP_NG(I)

IF (SUPARRAY(I).EQ.0 .AND. (SUPTYPE(I) .EQ. 3 .OR. &

SUPTYPE(I) .EQ. 7 .OR. SUPTYPE(I) .EQ. 8)) THEN

NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &

PKSHR_PROD(I) * ZFIXSUP(I)

NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - &

(1.-PKSHR_PROD(I)) * ZFIXSUP(I)

if (SUPTYPE(I) .EQ. 3) then

dum='lng '

else

dum='adgas'

endif

FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &

PKSHR_PROD(I) * ZFIXSUP(I)

FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &

(1.-PKSHR_PROD(I)) * ZFIXSUP(I)
! peak month

IF (SUPTYPE(I) .EQ. 3) THEN

PPERMTH(PKNET,I)=0.25

PPERMTH(OPNET,I)=.125

ENDIF

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &

(PKSHR_PROD(I) * ZFIXSUP(I) * PPERMTH(PKNET,I))

MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &

((1.-PKSHR_PROD(I)) * ZFIXSUP(I) * PPERMTH(OPNET,I))

ENDIF

ENDDO

! LNG EXPORTS

DO I=1,NLNGIMP

N = LNG_XMAP(I,3)

M = MNUMBX-4-NLNGIMP+I

NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * 

(1.+PERLIQFUEL))

NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * 

(1.-PKSHR_ELNG(I)) * (1.+PERLIQFUEL))

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + (oOGQNGEXP(M,CURIYR) * PKSHR_ELNG(I) * 

0.25 * (1.+PERLIQFUEL))

MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + (oOGQNGEXP(M,CURIYR) * 

(1.-PKSHR_ELNG(I))*0.125 * (1.+PERLIQFUEL))

ENDDO

NODE_CDMD(PKNET,7) = NODE_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * 

PKSHR_ELNG(I))

NODE_CDMD(OPNET,7) = NODE_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * 

(1.-PKSHR_ELNG(I)))

MTH_CDMD(PKNET,7) = MTH_CDMD(PKNET,7) - (REEXP(MODYR) * PERLIQFUEL * PKSHR_ELNG(I) 

* 0.25)

MTH_CDMD(OPNET,7) = MTH_CDMD(OPNET,7) - (REEXP(MODYR) * PERLIQFUEL * 

(1.-PKSHR_ELNG(I))*0.125)

DO I=1,DNODES

DO NET=1,NETWORK

NODE_CDMD(NET,I) = NODE_CDMD(NET,I) + ((BASQ_TRFV_SL(NET,I)+BASQ_TRPV_SL(NET,I) 

+ &

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

ENDDO

MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) + 

((BASQ_TRFV_SL(PKNET,I)+BASQ_TRPV_SL(PKNET,I) + &

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

MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) + 

((BASQ_TRFV_SL(OPNET,I)+BASQ_TRPV_SL(OPNET,I) + &

BASQ_TRLN_SR(OPNET,I)+BASQ_TRLN_SS(OPNET,I)) * 0.125 * (LNGV_LOSS/(1.-LNGV_LOSS)))

ENDDO

!rmv yd1 DO I=1,NLNGIMP

!rmv yd1 N = MAPLNG_NG(I)

!rmv yd1 NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &

!rmv yd1 PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1 NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - &

!rmv yd1 (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1

!rmv yd1 FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &

!rmv yd1 PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1 FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &

!rmv yd1 (1.-PKSHR_ILNG(I)) * oOGQNGIMP(10+I,CURIYR)

!rmv yd1 ! peak month

!rmv yd1 MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &
!rmv yd1 (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * 0.25) !1/4

!! (PKSHR_ILNG(I) * oOGQNGIMP(10+I,CURIYR) * PPERMTH(PKNET,N))

!rmv yd1 MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &

!rmv yd1 ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)* 0.125) !1/8

!! ((1.-PKSHR_ILNG(I))*oOGQNGIMP(10+I,CURIYR)*PPERMTH(OPNET,N))

!rmv yd1 ENDDO

! ADD CONST ON/OFF SHORE ADGAS

!rmv yd1 CALL NGSET_ADSUP

!rmv yd1 DO I=1,uSNODES ! 1-20

!rmv yd1 IF (SUPARRAY(I).EQ.1 .AND. SUPTYPE(I).LT.3) THEN ! Var conventional supply

!rmv yd1 IF (I .LE. NSUPSUB) THEN ! DEFINE L48 REG 1-12

!rmv yd1 N=SUPSUB_NG(I)

!rmv yd1 ELSE

!rmv yd1 N=SUPSUB_NG(OCSMAP(I-NSUPSUB))

!rmv yd1 ENDIF

!rmv yd1 NODE_CDMD(PKNET,N) = NODE_CDMD(PKNET,N) - &

!rmv yd1 PKSHR_PROD(I) * ZADGPRD(I)

!rmv yd1 FIXSUPIP(PKNET,N) = FIXSUPIP(PKNET,N) + &

!rmv yd1 PKSHR_PROD(I) * ZADGPRD(I)

!rmv yd1 NODE_CDMD(OPNET,N) = NODE_CDMD(OPNET,N) - &

!rmv yd1 (1.-PKSHR_PROD(I)) * ZADGPRD(I)

!rmv yd1 FIXSUPIP(OPNET,N) = FIXSUPIP(OPNET,N) + &

!rmv yd1 (1.-PKSHR_PROD(I)) * ZADGPRD(I)

! peak month

!rmv yd1 MTH_CDMD(PKNET,N) = MTH_CDMD(PKNET,N) - &

!rmv yd1 (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,I)) !by sup reg

!! (PKSHR_PROD(I) * ZADGPRD(I) * PPERMTH(PKNET,N)) !by ng reg

!rmv yd1 MTH_CDMD(OPNET,N) = MTH_CDMD(OPNET,N) - &

!rmv yd1 ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,I)) !by sup reg

!! ((1.-PKSHR_PROD(I)) * ZADGPRD(I) * PPERMTH(OPNET,N)) !by ng reg

!rmv yd1 ENDIF

!rmv yd1 ENDDO

RETURN

END

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

!

! SET CONST DMD AND SUPPLY TOTALS:

! YEAR_CDMD

!

! STATUS: COMPLETE

!

! CALLED BY: NGSET_NODECDMD

!

! FREQUENCY: 1ST ITERATION OF EVERY YEAR

!

! INPUT VARIABLES:

! ZTOTSUP(12) defined in NGSET_TOTSUP

! OGQNGIMP from OGSM model

! OGQNGEXP from OGSM model

! OGQANGTS(yr) from OGSM model

!

! OUTPUT VARIABLES:

!

! INCLUDES:

! <>L48 arc secondary flows

! <>import /export arcs (including CAN intermediate arcs)

! <>LNG imports

! <>SNG from liquid

! <>SNG from coal

! <>other supplemental

! <>Sable Island (part of Can const sup)

! >ANGTS

! >split CAN demand into P/O and add to CAN1 node
! >split CAN flow-thru into P/O and add to

! ?? border crossing path 3,15,24 only

! >discrepancy

!

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

SUBROUTINE NGSET_YEARCDMD

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'ngptmitm'

include 'ngakinc'

include 'ogglobal'

include 'ngsteoinc'

INTEGER*4 L,A ! COUNTERS

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 N ! NODE ID

INTEGER*4 SRC, DEST !

INTEGER*4 I,J,M !

INTEGER*4 BORDER ! NODE AT BORDER CROSSING

REAL*4 PKSHR ! SHR OF FLOW TO PEAK NETWORK

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

DO NET=1,NETWORK

DO N=1,TNODES

YEAR_CDMD(NET,N) = 0.0

MTHYR_CDMD(NET,N) = 0.0

ENDDO

ENDDO

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

IF (MODYR.GT.LHISYR) THEN

DO I=1,NMEX

J = NXMAPUS + I

M = NCAN + I

L = SNODE_2ARC(MEX_XMAP(I,2),MEX_XMAP(I,1))

SAFLOW(L,MODYR) = oOGQNGIMP(M,CURIYR)

L = SNODE_2ARC(MEX_XMAP(I,1),MEX_XMAP(I,2))

SAFLOW(L,MODYR) = oOGQNGEXP(M,CURIYR)

ENDDO

ENDIF

! SECONDARY FLOWS

DO A=1,SARCS

SRC = SARC_2NODE(A,1)

DEST= SARC_2NODE(A,2)

IF (SRC .NE. DEST) THEN

! src = lower 48

IF (SRC .LE. DNODES) THEN

IF (DEST .LE. DNODES) THEN

PKSHR = PKSHR_YR

ELSE IF(DEST .LE. DNODES+NCAN_BRD) THEN

PKSHR = PKSHR_ECAN

ELSE IF(DEST .LE. DNODES+NCAN_BRD+NMEX) THEN

PKSHR = PKSHR_EMEX

ENDIF
! src = canada border

ELSE IF(SRC .LE. DNODES+NCAN_BRD) THEN

IF (DEST .LE. DNODES) THEN

PKSHR = PKSHR_ICAN

ELSE IF(DEST .GT. DNODES+NCAN_BRD+NMEX) THEN

PKSHR = PKSHR_ECAN

ENDIF

! src = mexico

ELSE IF(SRC .LE. DNODES+NCAN_BRD+NMEX) THEN

IF (DEST .LE. DNODES) THEN

PKSHR = PKSHR_IMEX

ENDIF

! src = canada supply

ELSE

PKSHR = PKSHR_ICAN

ENDIF

YEAR_CDMD(PKNET,SRC) = YEAR_CDMD(PKNET,SRC) + &

PKSHR * SAFLOW(A,MODYR)

YEAR_CDMD(OPNET,SRC) = YEAR_CDMD(OPNET,SRC) + &

(1.-PKSHR) * SAFLOW(A,MODYR)

YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - &

PKSHR * SAFLOW(A,MODYR)

YEAR_CDMD(OPNET,DEST) = YEAR_CDMD(OPNET,DEST) - &

(1.-PKSHR) * SAFLOW(A,MODYR)

PTNETFLOW(PKNET,SRC,DEST) = PKSHR * SAFLOW(A,MODYR)

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

! peak month

MTHYR_CDMD(PKNET,SRC) = MTHYR_CDMD(PKNET,SRC) + &

(PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET))

MTHYR_CDMD(OPNET,SRC) = MTHYR_CDMD(OPNET,SRC) + &

((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET))

MTHYR_CDMD(PKNET,DEST)= MTHYR_CDMD(PKNET,DEST)- &

(PKSHR * SAFLOW(A,MODYR) *PERMTH(PKNET))

MTHYR_CDMD(OPNET,DEST)= MTHYR_CDMD(OPNET,DEST)- &

((1.-PKSHR) * SAFLOW(A,MODYR) *PERMTH(OPNET))

ENDIF

ENDDO

! -SNG FROM LIQ

! -SNG FROM COAL

! -OTHER SUPPLEMENTAL

!yd1: IF SUPPLIES ABOVE ARE NO MORE FIXED CHANGE BELOW USING ZFIXSUP VARIABLE

CALL NGSET_TOTSUP

DO N=1,DNODES

YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) - &

PKSHR_SUPLM * ZTOTSUP(N)

YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) - &

(1.-PKSHR_SUPLM) * ZTOTSUP(N)

! peak month

MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) - &

(PKSHR_SUPLM * ZTOTSUP(N) * 0.25) !1/4

!! (PKSHR_SUPLM * ZTOTSUP(N) * PPERMTH(PKNET,N))

MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) - &

((1.-PKSHR_SUPLM) * ZTOTSUP(N) * 0.125) !1/8

!! ((1.-PKSHR_SUPLM) * ZTOTSUP(N) * PPERMTH(OPNET,N))

ENDDO

! ANGTS

DEST = NODE_ANGTS

YEAR_CDMD(PKNET,DEST) = YEAR_CDMD(PKNET,DEST) - &

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

(1.-PKSHR_YR) * QAK_ALB(MODYR)

! peak month

MTHYR_CDMD(PKNET,DEST) = MTHYR_CDMD(PKNET,DEST) - &

(PKSHR_YR * QAK_ALB(MODYR) * 0.25) !1/4

!! (PKSHR_YR * QAK_ALB(MODYR) * PPERMTH(PKNET,DEST))

MTHYR_CDMD(OPNET,DEST) = MTHYR_CDMD(OPNET,DEST) - &

((1.-PKSHR_YR) * QAK_ALB(MODYR) * 0.125) !1/8

!! ((1.-PKSHR_YR) * QAK_ALB(MODYR) * PPERMTH(OPNET,DEST))

! CANADIAN DMD

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

DO I=1,2 ! EAST & WEST CANADA

N=TNODES-LNGNODES-2+I

YEAR_CDMD(PKNET,N) = YEAR_CDMD(PKNET,N) + &

PKSHR_CDMD * CN_DMD(I,MODYR) - &

PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - &

PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR)

! add following and those below if want canada lng exports accounted for in canada 

production

!!!! PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR) add + to previous

YEAR_CDMD(OPNET,N) = YEAR_CDMD(OPNET,N) + &

(1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - &

(1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - &

(1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR)

!!!! (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR) add + to previous

! peak month

MTHYR_CDMD(PKNET,N) = MTHYR_CDMD(PKNET,N) + (PERMTH(PKNET) * &

(PKSHR_CDMD * CN_DMD(I,MODYR) - &

PKSHR_PROD(SNODES-lSNODES-3) * CN_FIXSUP(I,MODYR) - &

PKSHR_ILNG(NLNGTER-3+I) * CNLNG_FLOW(I,MODYR) ))

!!!! PKSHR_ELNG(NLNGIMP+I) * oNALNGEXP(NLNGIMP+I,MODYR) )) delete )) from 

previous and add +

MTHYR_CDMD(OPNET,N) = MTHYR_CDMD(OPNET,N) + (PERMTH(OPNET) * &

((1.-PKSHR_CDMD) * CN_DMD(I,MODYR) - &

(1.-PKSHR_PROD(SNODES-lSNODES-3)) * CN_FIXSUP(I,MODYR) - &

(1.-PKSHR_ILNG(NLNGTER-3+I)) * CNLNG_FLOW(I,MODYR) ))

!!!! (1.-PKSHR_ELNG(NLNGIMP+I)) * oNALNGEXP(NLNGIMP+I,MODYR) )) delete )) from 

previous and add +

ENDDO

! DISCREPANCY (ADD TO DEMAND)

! L48

IF (MODYR .GT. EHISYR) THEN

IF (MODYR.GE.STEOYRS(1) .AND. (MODYR.LE.STPHAS_YR.OR.STPHAS_YR.EQ.0)) CALL 

xNGSTEO_BENCHDISCR

IF (MODYR.EQ.STEOYRS(STEO_YEAR)+1 .AND. STPHAS_YR.EQ.0) CALL xNGSTEO_BENCHDISCR

DO N=1,DNODES

DO NET=1,NETWORK

YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + &

DISCR(NET,N,MODYR)

! peak month

MTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + &

(DISCR(NET,N,MODYR) * PERMTH(NET))

ENDDO

ENDDO

! CANADA

DO I=1,2

N=TNODES-LNGNODES-2+I

DO NET=1,NETWORK

YEAR_CDMD(NET,N) = YEAR_CDMD(NET,N) + CN_DISCR(NET,I)

! peak month
MTHYR_CDMD(NET,N) = MTHYR_CDMD(NET,N) + &

(CN_DISCR(NET,I) * PERMTH(NET))

ENDDO

ENDDO

ENDIF

RETURN

END

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

!

! ADJUST CANADIAN DEMANDS BASED OFF ENDOGENOUS READ GIVEN RELATIVE PRICE CHANGES

!

! CALLED BY: NGSET_YEARCDMD

!

! FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD

!

! INPUT VARIABLES: CN_DMD, IT_WOP, OGCNPPRD

!

! OUTPUT VARIABLES: CN_DMD

!

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

SUBROUTINE NGADJ_CNDMD

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngcdmdinc'

include 'ogglobal'

REAL*4 A,B,SA,SB,NA,NB

REAL*4 BAS_CNPRC(IBASYR:IBASYR+MNUMYR-1)

REAL*4 BAS_WOP(IBASYR:IBASYR+MNUMYR-1)

! EM4 TRACK (this subr NGADJ_CNDMD no longer called)

DATA BAS_CNPRC /1.20,1.04,0.96,1.08,1.13,0.81,1.05,1.11,0.97, &

1.36,1.98,2.07,1.89,1.79,1.73,1.67,1.62,1.59,1.57,1.55, &

1.55,1.55,1.55,1.56,1.57,1.6,1.65,1.72,1.83,1.98,2.16, &

2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, &

2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16, &

2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16,2.16/

! EM4 TRACK (this subr NGADJ_CNDMD no longer called)

DATA BAS_WOP /19.58,16.25,15.44,16.36,12.60,13.61,16.06,14.14, 9.12,12.81, &

20.16,15.63,16.64,19.15,24.17,23.47,20.72,18.89,18.06,17.47, &

17.26,17.50,17.74,17.98,18.22,18.47,18.71,18.95,19.19,19.43, &

19.68,19.93,20.18,20.43,20.68,20.93,20.93,20.93,20.93,20.93,20.93, &

20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93, &

20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93,20.93/

! DATA BAS_WOP /19.50,16.17,15.38,13.31,12.55,13.55,15.99,14.08,9.08, &

! 12.75,20.10,15.61,16.54,18.31,17.05,16.50,16.61,16.71, &

! 16.81,16.91,17.01,17.11,17.21,17.31,17.42,17.53,17.63, &

! 17.74,17.85,17.96,18.06,18.22,18.38,18.53,18.68,18.84, &

! 18.84,18.84,18.84,18.84,18.84/

INTEGER*4 I

NA = (oIT_WOP(CURIYR-1,1) / BAS_WOP(MODYR-1))

NB = (oOGCNPPRD(2,CURIYR-1) / BAS_CNPRC(MODYR-1))

NB = 0.0 ! temporarily remove impact due to gas price change

! DO I=1,2

! CN_DMD(I,MODYR) = CN_DMD(I,MODYR) * (NA**0.5)

! ENDDO
CN_DMD(2,MODYR) = CN_DMD(2,MODYR) * (NA**0.2)

RETURN

END

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

!

! ADJUST CANADIAN DEMANDS USING ESTIMATED EQUATION ATTEMPTING

! TO REPRODUCE EXOGENOUS FORECAST ENDOGENOUSLY

!

! CALLED BY: NGSET_YEARCDMD

!

! FREQUENCY: 1ST ITERATION OF EVERY YEAR IN THE FORECAST PERIOD

!

! INPUT VARIABLES: CN_DMD, IT_WOP, OGCNPPRD

!

! OUTPUT VARIABLES: CN_DMD

!

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

SUBROUTINE XNGADJ_CNDMD

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngcdmdinc'

include 'ogglobal'

REAL*4 A,B

INTEGER*4 I

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

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

DO I=1,2

! EM4 TRACK -- routine not used

CN_DMD(I,MODYR) = CN_DMD(I,MODYR-1) * &

(1.08 + (0.048*A) + (-0.085*B) + (-0.0011*CURIYR))

ENDDO

RETURN

END

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

!

! SET TOTAL SUPPLEMENTAL SUPPLIES IN BCF

! - SNG FROM LIQUIDS

! - SNG FROM COAL

! - OTHER SUPPLEMENTAL

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_NODECDMD

!

! FREQUENCY: 1ST ITERATION OF EVERY YEAR

!

! INPUT VARIABLES:

! SNGLIQ(12,yr) defined in NGITM_READINIT

! SNGCOAL(yr) read in from miscdata

! SNGOTH(12,yr) other supplemental

!

! OUTPUT VARIABLES:
! ZTOTSUP(12)

!

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

SUBROUTINE NGSET_TOTSUP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

INTEGER*4 N ! NODE ID

INTEGER*4 I ! LOOP AROUND SUPPLY SOURCE

REAL*4 SUP_TOTAL ! TOTAL SUPPLEMENTAL SUP (CL, LNG, OTH)

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

!

! -- NGTDM REGIONS --

! SNGLIQ REGIONS 1 2 3 4 5 6 7 8 9 10 11 12 ! (region 3,12 used)

! NODE_SNGCOAL 4

! SNGOTH REGIONS 1 2 3 4 5 6 7 8 9 10 11 12

!

DO N=1,DNODES

ZTOTSUP(N) = 0.0

ENDDO

N = NODE_SNGCOAL ! SNG FROM COAL

!yd1 CTG ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(MODYR)

! OTHER SUPPLEMENTAL (12)

! SNG FROM LIQUIDS

DO N=1,DNODES

ZTOTSUP(N) = ZTOTSUP(N) + SNGOTH(N,MODYR)

ZTOTSUP(N) = ZTOTSUP(N) + SNGLIQ(N,MODYR)

ZTOTSUP(N) = ZTOTSUP(N) + SNGCOAL(N,MODYR)

ENDDO

RETURN

END

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

!

! SET FIXED SUPPLIES IN BCF

! - SNG FROM LIQUIDS

! - SNG FROM COAL

! - OTHER SUPPLEMENTAL

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_NODECDMD

!

! FREQUENCY: 1ST ITERATION OF EVERY YEAR

!

! INPUT VARIABLES:

! SNGLIQ(12,yr) defined in NGITM_READINIT

! SNGCOAL(12,yr) read in from miscdata

! SNGOTH(12,yr) other supplemental

! oOGQNGIMP LNG IMPORTS

! ZADGPRD(18) AD GAS

! QAK_ALB ALASKA

! CN_FIXSUP(cSNODES) CANADA

!

! OUTPUT VARIABLES:

! ZFIXSUP(91)
! PKSHR_PROD(91)

!

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

SUBROUTINE NGSET_FIXSUP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'ogglobal'

include 'ngakinc'

INTEGER*4 N,S,P ! CANADA

INTEGER*4 I ! LOOP AROUND SUPPLY SOURCE

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

!

DO I=1,SNODES

ZFIXSUP(I) = 0.0

ENDDO

! DO I=1,SNODES

! IF (SUPARRAY(I).EQ.0) THEN

! IF (SUPTYPE(I).EQ.3) PKSHR_PROD(I)=PKSHR_ILNG(SUPRGN(I))

! IF (SUPTYPE(I).EQ.4.OR.SUPTYPE(I).EQ.5.OR.SUPTYPE(I).EQ.6) 

PKSHR_PROD(I)=PKSHR_SUPLM

! IF (SUPTYPE(I).EQ.7.OR.SUPTYPE(I).EQ.8) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I))

! IF (SUPTYPE(I).EQ.9) PKSHR_PROD(I)=PKSHR_YR

! IF (SUPTYPE(I).GE.10) PKSHR_PROD(I)=PKSHR_PROD(SUPRGN(I))

! ENDIF

! ENDDO

DO I=1,SNODES

IF (I.GT.uSNODES) N=I-uSNODES

IF (SUPARRAY(I).EQ.0) THEN

IF (SUPTYPE(I).EQ.3 .AND. FIXLNGFLG) ZFIXSUP(I)=oOGQNGIMP(14+SUPREG(I),CURIYR) 

!LNG

IF (SUPTYPE(I).EQ.4) ZFIXSUP(I)=SNGCOAL(SUPREG(I),MODYR) !SUPL FROM COAL

IF (SUPTYPE(I).EQ.5) ZFIXSUP(I)=SNGLIQ(SUPREG(I),MODYR) !SUPL FORM LIQ

IF (SUPTYPE(I).EQ.6) ZFIXSUP(I)=SNGOTH(SUPREG(I),MODYR) !SUPL FROM OTH

IF (SUPTYPE(I).EQ.7) ZFIXSUP(I)=ZADGPRD(SUPREG(I)) !AD GAS ONSHORE

IF (SUPTYPE(I).EQ.8) ZFIXSUP(I)=ZADGPRD(SUPREG(I)+NSRGN(7)) !AD GAS OFFSHORE

IF (SUPTYPE(I).EQ.9) ZFIXSUP(I)=QAK_ALB(MODYR) !ALASKA

! IF (SUPTYPE(I).GE.10) ZFIXSUP(I)=CN_FIXSUP(N, MODYR) !CANADA

ENDIF

ENDDO

RETURN

END

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

!

! FILL NG CONSTANST SUPPLY VARIABLES

! ADGPRD(12) -ONSHORE AND OFFSHORE

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGSET_NODECDMD

!

! FREQUENCY: EVERY ITERATION OF EVERY YEAR

!

! INPUT VARIABLES:
! OGPRDADON(17,yr) from OGSM model

! OGPRDADOF(3,yr) from OGSM model

!

! OUTPUT VARIABLES:

! ZADGPRD(20)

!

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

!

SUBROUTINE NGSET_ADSUP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'nghistinc'

include 'ngsteoinc'

include 'ogglobal'

INTEGER*4 I,J ! COUNTERS

INTEGER*4 N ! NODE ID

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

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

DO J=1,NSRGN(7)+NSRGN(8)

ZADGPRD(J) = 0.0

ENDDO

IF (MODYR .LE. EHISYR) THEN

DO I=1,NSUPSUB ! ONSHORE AD GAS (17)

N = SUPSUB_NG(I)

ZADGPRD(I) = ZADGPRD(I) + HOGPRDAD(I,MODYR) * &

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

ENDDO

DO I=1,NOCSREG ! OFFSHORE AD GAS (3)

J = I+NSUPSUB ! 18-20

N = SUPSUB_NG(OCSMAP(I))

ZADGPRD(J) = ZADGPRD(J) + HOGPRDAD(J,MODYR) * &

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

ENDDO

ELSE

DO I=1,NSUPSUB ! ONSHORE AD GAS (17)

N = SUPSUB_NG(I)

ZADGPRD(I) = ZADGPRD(I) + oOGPRDADON(I,CURIYR) * &

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

IF (I.EQ.12) ZADGPRD(I) = ZADGPRD(I) + oOGSHALENG(CURIYR) * &

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

ENDDO

DO I=1,NOCSREG ! OFFSHORE AD GAS (3)

J = I+NSUPSUB ! 18-20

N = SUPSUB_NG(OCSMAP(I))

ZADGPRD(J) = ZADGPRD(J) + oOGPRDADOF(I,CURIYR) * &

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

ENDDO

ENDIF

RETURN

END

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

! PUT OGSM VARIABLES INTO NG ZOG... VARIABLES

! ZOGRESNG

! ZOGPRRNG

! ZOGCCAPPRD

! ZOGTAXPREM

!

! STATUS: PLACEHOLDER

!

! CALLED BY: NGITM_PRE

!

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

SUBROUTINE NGSET_ZOGVAR

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

include 'nghistinc'

include 'ogglobal'

INTEGER*4 I,J,L ! COUNTERS

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

DO I=1,NSUPSUB ! ONSHORE 1-17

IF (CURIYR .GT. 1) THEN

ZOGRESNGLAG1(I) = oOGRESNGON(I,CURIYR-1)

ZOGPRRLAG(I) = oOGPRRNGON(I,CURIYR-1)

ZOGRADNGLAG1(I) = oOGRADNGON(I,CURIYR-1)

ENDIF

IF (CURIYR .GT. 2) THEN

ZOGRESNGLAG2(I) = oOGRESNGON(I,CURIYR-2)

ZOGRADNGLAG2(I) = oOGRADNGON(I,CURIYR-2)

ENDIF

ZOGRESNG(I) = oOGRESNGON(I,CURIYR)

ZOGPRRNG(I) = oOGPRRNGON(I,CURIYR)

ZOGRADNG(I) = oOGRADNGON(I,CURIYR)

ZOGCCAPPRD(I) = oOGCCAPPRD(I,CURIYR)

ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR)

IF (MODYR.EQ.IBASYR) THEN

ZWPROLL = 0.0

ZWPROLL(I,1) = PSUP(I)

ZWPRLAG(I) = PSUP(I)

ELSEIF (MODYR.EQ.IBASYR+1) THEN

ZWPRLAG(I) = HPSUP(I,MODYR)

ELSEIF (MODYR.LE.EHISYR) THEN

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = HPSUP(I,MODYR-1)

ZWPRLAG(I) = HPSUP(I,MODYR)

ELSEIF (MODYR .EQ. EHISYR+1) THEN

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = HPSUP(I,MODYR-1)

ZWPRLAG(I) = PSUP(I)

ELSE

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = PSUP(I)
ZWPRLAG(I) = PSUP(I)

ENDIF

ENDDO

DO J=1,NOCSREG ! OFFSHORE 1-3

I = J+NSUPSUB

IF (CURIYR .GT. 1) THEN

ZOGRESNGLAG1(I) = oOGRESNGOF(J,CURIYR-1)

ZOGPRRLAG(I) = oOGPRRNGOF(J,CURIYR-1)

ZOGRADNGLAG1(I) = oOGRADNGOF(J,CURIYR-1)

ENDIF

IF (CURIYR .GT. 2) THEN

ZOGRESNGLAG2(I) = oOGRESNGOF(J,CURIYR-2)

ZOGRADNGLAG2(I) = oOGRADNGOF(J,CURIYR-2)

ENDIF

ZOGRESNG(I) = oOGRESNGOF(J,CURIYR)

ZOGPRRNG(I) = oOGPRRNGOF(J,CURIYR)

ZOGRADNG(I) = oOGRADNGOF(J,CURIYR)

ZOGCCAPPRD(I) = 0.0

ZOGTAXPREM(I) = oOGTAXPREM(2,CURIYR)

IF (MODYR.EQ.IBASYR) THEN

ZWPROLL(I,1) = PSUP(I)

ZWPRLAG(I) = PSUP(I)

ELSEIF (MODYR.EQ.IBASYR+1) THEN

ZWPRLAG(I) = PSUP(I)

ELSEIF (MODYR.LE.EHISYR) THEN

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = HPSUP(I,MODYR-1)

ZWPRLAG(I) = HPSUP(I,MODYR)

ELSEIF (MODYR .EQ. EHISYR+1) THEN

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = HPSUP(I,MODYR-1)

ZWPRLAG(I) = PSUP(I)

ELSE

DO L=IROLL,2,-1

ZWPROLL(I,L) = ZWPROLL(I,L-1)

ENDDO

ZWPROLL(I,1) = PSUP(I)

ZWPRLAG(I) = PSUP(I)

ENDIF

ENDDO

IF (ZOGRESNG(18).GT.0.AND.ZOGRESNGLAG1(18).LT.1.0) ZOGRESNGLAG1(18) = 1.0 ! START 

UP ATL OCS

IF (CURIYR .GT. 1) THEN

ZOGRESNGLAG1(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-1)

ZOGPRRLAG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR-1)

ENDIF

IF (CURIYR.GT.2) THEN

ZOGRESNGLAG2(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR-2)

ENDIF

ZOGRESNG(SNODES-lSNODES-3) = oOGRESCAN(2,CURIYR)

ZOGPRRNG(SNODES-lSNODES-3) = oOGPRRCAN(2,CURIYR)

ZOGCCAPPRD(SNODES-lSNODES-3) = 0.0

ZOGTAXPREM(SNODES-lSNODES-3) = 0.0

IF (MODYR.EQ.IBASYR) THEN

ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3)

ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)

ELSEIF (MODYR.EQ.IBASYR+1) THEN

ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)

ELSEIF (MODYR .LE.EHISYR) THEN
DO J=IROLL,2,-1

ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)

ENDDO

ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1)

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

ELSEIF (MODYR .EQ. EHISYR+1) THEN

DO J=IROLL,2,-1

ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)

ENDDO

ZWPROLL(SNODES-lSNODES-3,1) = HPSUP(SNODES-lSNODES-3,MODYR-1)

ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)

ELSE

DO J=IROLL,2,-1

ZWPROLL(SNODES-lSNODES-3,J) = ZWPROLL(SNODES-lSNODES-3,J-1)

ENDDO

ZWPROLL(SNODES-lSNODES-3,1) = PSUP(SNODES-lSNODES-3)

ZWPRLAG(SNODES-lSNODES-3) = PSUP(SNODES-lSNODES-3)

ENDIF

RETURN

END

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

!

! SET MAXIMUM ALLOWABLE ANNUAL CAPACITY BY ARC

! MAXPCAP

!

! STATUS: COMPLETE

!

! CALLED BY: NGITM_PRE

!

! NOTE: THIS MUST BE CALLED AFTER ZOGRESNG IS SET IN NGSET_ZOGVAR

!

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

!

SUBROUTINE NGSET_MAXPCAP

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngptmitm'

include 'ngsteoinc'

include 'ngcdmdinc'

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

INTEGER*4 L,A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

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

INTEGER*4 SID ! SUPPLY ID (1-21)

INTEGER*4 LID ! NODE ON LNG SUPPLY COUNT (1-3)

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

INTEGER*4 NREG ! NG REG ID

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

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

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

DO L=1,NPROC

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

ARC_2 = ARC_LOOP(PKNET,DEST,2)

! write(6,*) '2nd_LOOP',dest,arc_1,arc_2,l,nproc

ENDDO

DO L=1,NPROC

DEST = PROC_ORD(L)

! write(6,*) '1st_LOOP',dest,pknet,l,nproc

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

! NO BUILDS ALLOWED BEFORE NOBLDYR, AND FOR CANADIAN IMPORTS

IF ((MODYR .LE. NOBLDYR) .OR. &

( ((SRC.GT.DNODES) .AND. (SRC.LE.DNODES+NCAN_BRD) .AND. &

(DEST.LE.DNODES) .AND. (CNCAPSW.EQ.0)) ) .OR. &

( (DEST.GT.DNODES) .AND. (DEST.LE.DNODES+NCAN_BRD) .AND. &

(SRC.EQ.TNODES-LNGNODES .OR. SRC.EQ.TNODES-LNGNODES-1) &

.AND. (CNCAPSW.EQ.0) )) THEN

IF ((SRC .LE. TNODES) .OR. &

(SRC .GT. (TNODES+SNODES))) THEN ! PIPE & STORAGE

MAXPCAP(PKNET,A) = CURPCAP(A,MODYR)

ELSE ! SUPPLY

SID = SRC - TNODES

IF(SUPARRAY(SID).NE.0) THEN

NREG = NG_NREG(SID) ! function: NG REG ID

! w/o L&P

IF (MODYR .LE. EHISYR) THEN

MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC

ELSE

IF (SUPTYPE(SID).EQ.14) THEN ! LNG, hardcoded

LID = SID-FSRGN(14)+1 ! LNG SUP COUNT (1-3)

MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + & !JBEMAX

MAXPLNG(LID,OPNET,MODYR) !JBEMAX

ELSE

MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &

MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))

ENDIF

ENDIF

CURPCAP(A,MODYR) = MAXPCAP(PKNET,A)

ENDIF

ENDIF

ELSE

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS

MAXPCAP(PKNET,A) = PTMAXPCAP(SRC,DEST)

ELSE IF (SRC .GT. (TNODES+SNODES)) THEN ! STR ARCS

STID = SRC - (TNODES+SNODES) ! 1-14

MAXPCAP(PKNET,A) = PTMAXPSTR(STID)

ELSE ! SUPPLY ARCS

SID = SRC - TNODES

IF(SUPARRAY(SID).NE.0) THEN

NREG = NG_NREG(SID) ! function: NG REG ID

! w/o L&P

IF (MODYR .LE. EHISYR) THEN

MAXPCAP(PKNET,A) = QSUP(SID) * MAXPRRFAC

ELSE

IF (SUPTYPE(SID).EQ.10) THEN ! CANADA, hardcoded

MAXPRRCAN = 1. + (MAXPRRFAC-1.) * 1.00

MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &

MAXPRRCAN * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))

ELSEIF (SUPTYPE(SID).EQ.14) THEN ! LNG, hardcoded !JBEMAX

LID = SID-FSRGN(14)+1 ! LNG SUP COUNT (1-3)
MAXPCAP(PKNET,A) = MAXPLNG(LID,PKNET,MODYR) + & !JBEMAX

MAXPLNG(LID,OPNET,MODYR) !JBEMAX

ELSE !JBEMAX

MAXPCAP(PKNET,A) = ZOGRESNG(SID) * ZOGPRRNG(SID) * &

MAXPRRFAC * (1. - (PCTLP(NREG) * SCALE_LP(MODYR)))

ENDIF

ENDIF

ENDIF

CURPCAP(A,MODYR) = MAXPCAP(PKNET,A)

ENDIF

ENDIF

MAXPCAP(OPNET,A) = MAXPCAP(PKNET,A)

ENDDO

ENDDO

RETURN

END

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

INTEGER FUNCTION NG_NREG(IREG)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

INTEGER*4 IREG ! SUPPLY REG ID (1-17,18-20,21)

INTEGER*4 DEST ! TREE NODE

INTEGER*4 I ! OCS MAPPING INTO SUP REG ID

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

IF (SUPARRAY(IREG) .NE. 0) THEN

NG_NREG = MAP_NG(IREG)

IF (IREG .EQ. SNODES - 5) NG_NREG = DNODES+1 ! FOR CAN SUPPLY

ENDIF

RETURN

END

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

SUBROUTINE NGITM_DEBUG1

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 L,N,A,I,J,K ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

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

LOGICAL PRTMAT/.TRUE./

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

! PRINT NEW MATRICES: NODE_2ARC, ARC_2NODE, ARC_LOOP

IF (PRTMAT) THEN ! this print is turned off

PRTMAT = .FALSE.
IF (TNODES .LT. 25) THEN

K=TNODES

ELSE

K=25

ENDIF

WRITE(NGOERR,*) ' NODE_2ARC: 1 2 3 4 5 6 7 8 9 10 ', &

'11 12 13 14 15 16 17 18 19 20 21 22 23 24 25'

DO I=1,NODES

WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=1,K)

ENDDO

IF (TNODES .GT. 25) THEN

K=TNODES

IF (TNODES .GE. 50) K=50

WRITE(NGOERR,*) ' NODE_2ARC:26 27 28 29 30 ... 50'

DO I=1,NODES

WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=26,K)

ENDDO

ENDIF

IF (TNODES .GT. 50) THEN

K=TNODES

IF (TNODES .GE. 75) K=75

WRITE(NGOERR,*) ' NODE_2ARC:51 52 53 54 55 ... 75'

DO I=1,NODES

WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=51,K)

ENDDO

ENDIF

IF (TNODES .GT. 75) THEN

K=TNODES

IF (TNODES .GE. 100) K=50

WRITE(NGOERR,*) ' NODE_2ARC:76 77 78 79 80 ... 100'

DO I=1,NODES

WRITE(NGOERR,100) I,(NODE_2ARC(I,J),J=76,K)

ENDDO

ENDIF

WRITE(NGOERR,*) ' ARC_2NODE: SRC DEST'

I=1

DO WHILE (ARC_2NODE(I,1) .NE. 0)

WRITE(NGOERR,101) I,(ARC_2NODE(I,J),J=1,2)

I = I+1

ENDDO

WRITE(NGOERR,*) ' == PEAK == == OFFPEAK =='

WRITE(NGOERR,*) ' ARC_LOOP: START STOP START STOP'

DO I=1,TNODES

WRITE(NGOERR,102) I,(ARC_LOOP(PKNET,I,J),J=1,2), &

(ARC_LOOP(OPNET,I,J),J=1,2)

ENDDO

ENDIF

100 FORMAT(5X,I2,4X,50(1X,I2))

101 FORMAT(5X,I2,2X,2(3X,I2))

102 FORMAT(5X,I2,2X,2(4X,I2),2X,2(4X,I2))

RETURN

END

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

!

! REPORT NODE INFO ON ALL NETWORKS (PK, OP)

!

! BKSTOP

! PIPEFUEL

! DEMAND

! SHRPR

! ENDPR
!

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

SUBROUTINE NGITM_DEBUG2(OUTPUT)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 TDMD ! TOTAL DMD ACROSS ALL NETWORKS (BCF)

REAL*4 BK(NETWORK) ! HOLDS BACKSTOP QTY

REAL*4 PF(NETWORK) ! HOLDS PIPE FUEL CONSUMPTION

CHARACTER*3 ID ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T)

CHARACTER*2 RID(96) ! USED TO TRANSFER VALUE TO CHARACTER

CHARACTER*1 CNV(NETWORK)! FLAGS IF NON-CONVERGENCE ON SUPPLY

CHARACTER*5 OUTID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

CHARACTER*5 HEADID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

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

'11','12','13','14','15','16','17','18','19','20', &

'21','22','23','24','25','26','27','28','29','30', &

'31','32','33','34','35','36','37','38','39','40', &

'41','42','43','44','45','46','47','48','49','50', &

'51','52','53','54','55','56','57','58','59','60', &

'61','62','63','64','65','66','67','68','69','70', &

'71','72','73','74','75','76','77','78','79','80', &

'81','82','83','84','85','86','87','88','89','90', &

'91','92','93','94','95','96'/

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

IF (FCRL .EQ. 1) THEN

OUTID = 'DB04Z'

HEADID = 'DB04X'

WRITE(OUTPUT,*) ' DB04X: REPORT NODE LEVEL INFO'

ELSE

OUTID = 'DB02A'

HEADID = 'DB02X'

WRITE(OUTPUT,*) ' DB02X: REPORT NODE LEVEL INFO'

ENDIF

WRITE(OUTPUT,105) HEADID

WRITE(OUTPUT,115) HEADID

DO DEST=1,NODES

TDMD = 0.0

DO NET=1,NETWORK

TDMD = TDMD + NODE_DMD(NET,DEST)

CNV(NET) = ' '

ENDDO

IF (DEST .GT. TNODES) THEN

DO NET=1,NETWORK

BK(NET) = 0.0

PF(NET) = 0.0

ENDDO

IF (DEST .LE. TNODES+SNODES) THEN
I = DEST - TNODES

ID = 'S' // RID(I) ! SUPPLY

IF (PSUP_CNVG(PKNET,I) .EQ. 0) CNV(PKNET)= 'X'

IF (PSUP_CNVG(OPNET,I) .EQ. 0) CNV(OPNET)= 'X'

ENDIF

IF (DEST .GT. TNODES+SNODES) THEN

I = DEST - (TNODES+SNODES)

ID = 'T' // RID(I) ! STORAGE

ENDIF

ELSE

DO NET=1,NETWORK

BK(NET) = BKSTOP(NET,DEST)

PF(NET) = PFUEL(NET,DEST)

ENDDO

IF (DEST .LE. DNODES) THEN

ID = 'D' // RID(DEST) ! L48 DEMAND NODES

ELSE

ID = 'I' // RID(DEST) ! CAN/MEX NODES

ENDIF

ENDIF

IF (DEST .LE. TNODES .OR. DEST .GT. TNODES+SNODES) THEN

WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, &

BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), &

CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD

ELSEIF (SUPARRAY(DEST-TNODES) .EQ. 1) THEN

WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (DEST, ID, &

BK(NET), PF(NET), NODE_DMD(NET,DEST), NODE_SHRPR(NET,DEST), &

CNV(NET),NODE_ENDPR(NET,DEST), NET=1,NETWORK), TDMD

ENDIF

ENDDO

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

2X,18('-'),' PEAK ',18('-'),7X, &

2X,18('-'),' OFFPEAK ',18('-'), &

2X,'TOTDMD')

115 FORMAT(1X,A5,' YR ITR CYC NODE ', &

'BKSTOP PFUEL NETDMD SHRPR ENDPR', &

' NODE ', &

'BKSTOP PFUEL NETDMD SHRPR ENDPR', &

' TOTDMD')

120 FORMAT(1X,A5,1X,I4, 2(2X,I3), &

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

2X,F9.1)

RETURN

END

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

!

! REPORT ARC LEVEL INFO FOR ALL NETWORKS

! SHR, FLOW, ARC_ENDFEE, ARC,SHRFEE

!

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

SUBROUTINE NGITM_DEBUG3(OUTPUT)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)
INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 CUR_EFFCAP(NETWORK,ARCS) ! CURRENT EFFECTIVE CAPACITY

REAL*4 MAX_EFFCAP(NETWORK,ARCS) ! MAXIMUM EFFECTIVE CAPACITY

REAL*4 PKFAC ! FACTOR USE TO CALC EFF CAP

REAL*4 TFLO ! TOTAL ANNUAL FLOW ALONG ARC

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

CHARACTER*3 ID ! ID NODE AS L48(D), CAN/MEX(I), SUP(S), STOR(T)

CHARACTER*2 RID(96) ! USED TO TRANSFER VALUE TO CHARACTER

CHARACTER*5 OUTID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

CHARACTER*5 HEADID ! USED TO DISTINGUISH LAST ITR FROM OTHERS

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

'11','12','13','14','15','16','17','18','19','20', &

'21','22','23','24','25','26','27','28','29','30', &

'31','32','33','34','35','36','37','38','39','40', &

'41','42','43','44','45','46','47','48','49','50', &

'51','52','53','54','55','56','57','58','59','60', &

'61','62','63','64','65','66','67','68','69','70', &

'71','72','73','74','75','76','77','78','79','80', &

'81','82','83','84','85','86','87','88','89','90', &

'91','92','93','94','95','96'/

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

IF (NCRL .EQ. 1) THEN ! store flow in PRV var for use next model yr

DO NET=1,NETWORK

DO A=1,NARCS

PRVFLOW(NET,A) = FLOW(NET,A)

ENDDO

DO DEST=1,TNODES

PRVNODE_DMD(NET,DEST) = NODE_DMD(NET,DEST)

ENDDO

ENDDO

RETURN

ENDIF

IF (FCRL .EQ. 1) THEN

OUTID = 'DB05Z'

HEADID = 'DB05X'

WRITE(OUTPUT,*) ' DB05X: REPORT ARC LEVEL INFO'

ELSE

OUTID = 'DB03A'

HEADID = 'DB03X'

WRITE(OUTPUT,*) ' DB03X: REPORT ARC LEVEL INFO'

ENDIF

WRITE(OUTPUT,105) HEADID

WRITE(OUTPUT,115) HEADID

DO L=1,NPROC

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

TFLO = 0.0

DO NET=1,NETWORK

MAX_EFFCAP(NET,A) = NGSET_MAXFLO(NET,A)

TFLO = TFLO + FLOW(NET,A)

ENDDO

IF (SRC .GT. TNODES+SNODES) THEN ! storage

CUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A)

ELSE IF(SRC .LE. TNODES) THEN ! pipe
CUR_EFFCAP(PKNET,A) =CURPCAP(A,MODYR) *PKUTZ(A) *PKSHR_YR

ELSE ! supply

CUR_EFFCAP(PKNET,A) =MAX_EFFCAP(PKNET,A)

ENDIF

CUR_EFFCAP(OPNET,A) = MAX_EFFCAP(OPNET,A)

IF (SRC .GT. TNODES) THEN

IF (SRC .LE. TNODES+SNODES) THEN

I = SRC - TNODES

ID = 'S' // RID(I) ! SUPPLY

ENDIF

IF (SRC .GT. TNODES+SNODES) THEN

I = SRC - (TNODES+SNODES)

ID = 'T' // RID(I) ! STORAGE

ENDIF

ELSE

IF (SRC .LE. DNODES) THEN

ID = 'D' // RID(SRC) ! L48 DEMAND NODES

ELSE

ID = 'I' // RID(SRC) ! CAN/MEX NODES

ENDIF

ENDIF

if (modyr.gt.1990) WRITE(OUTPUT,120) OUTID, MODYR, CURITR, CYCLE, (SRC, ID, 

DEST, &

ARC_SHRFEE(NET,A), ARC_SHRPR(NET,A), SHR(NET,A,MODYR), shr(net,a,modyr-1), &

FLOW(NET,A), CUR_EFFCAP(NET,A), MAX_EFFCAP(NET,A), &

NET=1,NETWORK), TFLO

ENDDO

ENDDO

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

3X,20('-'),' PEAK ',20('-'),13X, &

3X,20('-'),' OFFPEAK ',20('-'))

115 FORMAT(1X,A5,' YR ITR CYC SRC DEST ', &

'ARCFEE SHRPR SHR FLOW EFFCAP EFFMAX', &

' SRC DEST ', &

'ARCFEE SHRPR SHR FLOW EFFCAP EFFMAX', &

' TOTFLO')

120 FORMAT(1X,A5,1X,I4, 2(1X,I3), 2(2X,'|',2X,I3, 1X,A3, 1X,I3, &

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

RETURN

END

!

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

!

SUBROUTINE NGITM_DEBUG6(OUTPUT)

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

INTEGER*4 L,N,A,I,J ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 DUMMY/0.0/ ! DUMMY VARIABLE

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

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

WRITE(OUTPUT,105)

WRITE(OUTPUT,115)

DO L=1,NPROC

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

WRITE(OUTPUT,120) CYCLE, SRC, DEST, &

(ARC_ENDFEE(NET,A), &

NODE_ENDPR(NET,SRC), NODE_ENDPR(NET,DEST), &

NODE_SHRPR(NET,SRC), NODE_SHRPR(NET,DEST), &

NET=1,2)

ENDDO

ENDDO

DO N=1,SNODES

IF (SUPARRAY(N).EQ.1) THEN

DEST = TNODES+N

SRC = 0

WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, &

DUMMY, NODE_ENDPR(NET,DEST), &

DUMMY, NODE_SHRPR(NET,DEST), &

NET=1,2)

ENDIF

ENDDO

DO N=1,STNODES

DEST = TNODES+SNODES+N

SRC = 0

WRITE(OUTPUT,120) CYCLE,SRC,DEST, (DUMMY, &

DUMMY, NODE_ENDPR(NET,DEST), &

DUMMY, NODE_SHRPR(NET,DEST), &

NET=1,2)

ENDDO

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

6X,20('-'),' OFFPEAK ',20('-'))

115 FORMAT(1X,'CYCLE', 3X,'NODE', &

7X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', &

9X,'ARCFEE', 9X,'ENDPR', 13X,'SHRPR', &

/8X,'S D',2(20X,'S',7X,'D',9X,'S',7X,'D'))

120 FORMAT(1X,I3, 2X,2I3, 2X,2(3X,F8.2,2(2X,2F8.2)))

RETURN

END

!

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

!

SUBROUTINE NGITM_DEBUG7(OUTPUT)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'

include 'nghistinc'

include 'ngptmitm' ! temp

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

INTEGER*4 DEST ! NODE ON TREE (DEST NODE)

INTEGER*4 SRC ! SOURCE NODE ALONG ARC

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 OUTPUT ! OUTPUT UNIT NUMBER

REAL*4 TDMD ! TOTAL DMD ACROSS ALL NETWORKS (BCF)

REAL*4 TFLO ! TOTAL FLO ACROSS ALL NETWORKS (BCF)

REAL*4 PKSH ! PKSHR FOR FLOWS/DMDS (FRACTION)

REAL*4 DIFFLO ! HAFLOW - TDMD

REAL*4 TMAX(NETWORK) ! TOTAL MAX FLO (BCF)

REAL*4 DUMMY0/0.0/ ! DUMMY VARIABLE

REAL*4 DUMMY1/1.0/ ! DUMMY VARIABLE

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 TEMP ! TEMPORARY HOLDING VARIABLE

REAL*4 ATEMP(NXMAPCN) ! TEMPORARY HOLDING VARIABLE

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

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

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

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

WRITE(OUTPUT,105) MODYR

WRITE(OUTPUT,115)

DO L=1,NPROC

DEST = PROC_ORD(L)

SRC = 0

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

TDMD = 0.0

DO NET=1,NETWORK

TDMD = TDMD + NODE_DMD(NET,DEST)

TMAX(NET) = 0.0

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (NET .EQ. OPNET) THEN ! ????

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION

ENDIF

IF ((NET .EQ. OPNET) .AND. (SRC .GT. TNODES+SNODES)) THEN

! DO NOT ADD STORAGE CAPACITY TO OP TMAX

ELSE

TMAX(NET) = TMAX(NET) + MAXFLO(NET,A)

ENDIF

ENDDO

X(NET)=' '

IF (NODE_DMD(NET,DEST) .GT. TMAX(NET)) THEN

X(NET)='X'

ENDIF

ENDDO

IF (TDMD .GT. 0.0) THEN

PKSH = NODE_DMD(PKNET,DEST) / TDMD

ELSE

PKSH = 0.0

ENDIF

WRITE(OUTPUT,110) CYCLE, DEST, &

(NODE_DMD(NET,DEST), TMAX(NET), X(NET), &

NET=1,NETWORK), TDMD, PKSH

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

TFLO = 0.0
DO NET=1,NETWORK

TFLO = TFLO + FLOW(NET,A)

X(NET)=' '

IF (FLOW(NET,A) .GT. MAXFLO(NET,A)) THEN

X(NET)='X'

ENDIF

ENDDO

IF (TFLO .GT. 0.0) THEN

PKSH = FLOW(PKNET,A) / TFLO

ELSE

PKSH = 0.0

ENDIF

IF (MODYR .LE. EHISYR) THEN

DIFFLO = HAFLOW(A,MODYR) - TFLO

ELSE

DIFFLO = 0.0

ENDIF

WRITE(OUTPUT,120) CYCLE, SRC, DEST, &

(SHR(NET,A,MODYR), FLOW(NET,A), MAXFLO(NET,A), X(NET), &

NET=1,NETWORK), TFLO, DIFFLO, PKSH

ENDDO

ENDDO

WRITE(OUTPUT,*) ' XXX SECONDARY CAPACITY'

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

DO A=1,SARCS

SRC = SARC_2NODE(A,1)

DEST= SARC_2NODE(A,2)

WRITE(OUTPUT,130) SRC,DEST,SACTPCAP(A),SAFLOW(A,MODYR)

ENDDO

! temp

WRITE(OUTPUT,150)

DO L=1,NPROC

DEST = PROC_ORD(L)

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC.LE.TNODES) THEN

TEMP = PTMAXPCAP(SRC,DEST)

ELSE

TEMP = 0.0

ENDIF

WRITE(OUTPUT,140) MODYR,SRC,DEST,TEMP, &

MAXPCAP(OPNET,A),CURPCAP(A,MODYR),ACTPCAP(A)

ENDDO

ENDDO

140 FORMAT(1X,'PTMAXPCAP: ',I4,I4,I4,4F10.2)

150 FORMAT(1X,'PTMAXPCAP: YR SRC DEST PTMAXPCAP MAXPCAP CURPCAP ACTPCAP')

! temp

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

WRITE(OUTPUT,*) 'ARC_VARTAR-CN: YEAR 23->13 23->14', &

' 23->15 24->16 24->17 24->18 24->19'

DO NET=1,NETWORK

WRITE(OUTPUT,*) 'ARC_VARTAR-CN: NET= ',NET

DO L=IBASYR,LASTYR+IBASYR-1

DO I=1,NXMAPCN

IF (CAN_XMAPCN(I,1).NE.15) THEN

ATEMP(I) = ARC_VARTAR(NET,NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1)),L)

ELSE

ATEMP(I) = 0.0

ENDIF

ENDDO
WRITE(OUTPUT,160) L, (ATEMP(I),I=1,NXMAPCN) ! WRITE CANADIAN ARC_VARTAR

ENDDO

ENDDO

ENDIF

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

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

105 FORMAT(1X,'YR=',I4,2X,15X,' PEAK ',19X,' OFFPEAK ')

115 FORMAT(1X,'CYCLE', 2X,'SRC DEST', &

5X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', &

6X,'SHR', 4X, 'QUANT', 5X,'MAXQ ', &

5X,'TDMD',2X,'DIFF',5X,'PKDMD')

110 FORMAT(1X,I3, 6X, I3, 1X,2( 9X, 2(F9.2),A1), &

1X,F9.2,6X,1X,F9.3)

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

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

RETURN

END

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

SUBROUTINE NGTDM_SENSITIVITY(A,B)

IMPLICIT NONE

REAL*4 A

REAL*4 B

! -------

RETURN

END

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

!

! HISTORICAL YEAR VERSION OF NEW INTERSTATE TRANSMISSION MODULE (ITM)

!

! STATUS:

!

! CALLED BY: NGMAIN

!

! CALLS: NGITM_PRE ! PREPROCESSOR

! NGSET_NODEDMD ! SET NET DMDS

! HNGDOWN_TREE(NET) ! DEFINE NODE DMDS & FLOWS

! HNGSET_SUPPR ! SET SUPPLY PR USING CURVE

! NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

! NGSET_STORPR ! SET STORAGE PRICE

! NGUP_TREE(NET) ! SET NODE PRICE

! NGSET_SECPR ! SET END-USE SECTOR PRICES

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

! ??? NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ

! ??? NGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

!

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

!

SUBROUTINE HNGTDM_ITM

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

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

CALL NGITM_PRE ! PREPROCESSING FOR THE ITM

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

IF (CURITR .EQ. 1) THEN

CALL NGHIST_DISCR ! SET DISCREPANCIES

ENDIF

CALL HNGDOWN_TREE ! SET HIST SHARES, FLOWS BY SEASON

CALL HNGSET_SUPPR ! SET HIST SUPPLY PRICES BY SEASON

CALL NGSET_ARCFEE ! SET FIX/VAR TAR ALONG ARCS

DO NET=NETWORK,1,-1 ! SET NODE & STORAGE PR

IF (NET .EQ. PKNET) CALL NGSET_STORPR

CALL NGUP_TREE(NET)

ENDDO

CALL HNGSET_CGPR ! SET CITYGATE PRICES AND BENCHMARK FAC

!??? CALL NGITM_BASPR ! SET BASPR FOR PO IN DMD CURVE EQ

CALL HNGSET_ACTPCAP ! SET ACTUAL/FINAL CAPACITIES ON ARCS

! DEBUG REPORTS

IF (NGDBGITR(4,2) .OR. NGDBGITR(4,12)) THEN

CALL NGITM_DEBUG2(NGOTREE)

CALL NGITM_DEBUG3(NGOTREE)

ENDIF

IF (NGDBGITR(4,1) .OR. NGDBGITR(4,11)) THEN

CALL NGITM_DEBUG7(NGOBAL)

ENDIF

RETURN

END

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

! SET SEASONAL DISCREPANCIES TO BALANCE SUPPLY AND DEMAND (L48)

! FIRST BALANCE CANADA

! CALLED IF CURITR.EQ.1 .AND. MODYR.LE.EHISYR

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

SUBROUTINE NGHIST_DISCR

IMPLICIT NONE

!

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'nghistinc'

include 'ngcdmdinc'

include 'ngitminc'

include 'ngtdminc'

REAL*4 PKDISCR ! DISCREPANCY IN THE PEAK PERIOD

REAL*4 OPDISCR ! DISCREPANCY IN THE OFFPEAK PERIOD

REAL*4 NATDISCR ! NATIONAL ANNUAL DISCREPANCY

REAL*4 REGADJ ! REGIONAL ADJUSTMENT OF REGIONAL ANNUAL DISCREPANCY

REAL*4 PKADJ ! REGIONAL DIFFERENCE PEAK DISCREANCY AND ANNUAL DISCR

INTEGER*4 A ! ARC

INTEGER*4 AI ! IMPORT ARC

INTEGER*4 AE ! EXPORT ARC
INTEGER*4 NET ! NETWORK INDEX

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

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

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

DO M=1,2 ! EAST=1, WEST=2

HCN_DISCR(PKNET,M,MODYR) = HNETWTH(STNODES-2+M,MODYR) - &

NODE_DMD(PKNET,TNODES-LNGNODES-2+M)

HCN_DISCR(OPNET,M,MODYR) = -1.* HNETINJ(STNODES-2+M,MODYR) - &

NODE_DMD(OPNET,TNODES-LNGNODES-2+M)

ENDDO

HCN_DISCR(PKNET,2,MODYR) = HCN_DISCR(PKNET,2,MODYR) + &

(QSUP(SNODES-lSNODES-3) * PKSHR_PROD(SNODES-lSNODES-3) )

HCN_DISCR(OPNET,2,MODYR) = HCN_DISCR(OPNET,2,MODYR) + &

(QSUP(SNODES-lSNODES-3) * (1. - PKSHR_PROD(SNODES-lSNODES-3)) )

DO I=1,NXMAPCN

AI = NODE_2ARC(CAN_XMAPCN(I,2),CAN_XMAPCN(I,1))

AE = SNODE_2ARC(CAN_XMAPCN(I,1),CAN_XMAPCN(I,2))

IF (CAN_XMAPCN(I,2) .EQ. TNODES-LNGNODES) THEN

M = 2

HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - &

( HAFLOW(AI,MODYR) * PKSHR_ICAN)

HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - &

( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) )

ELSE

M = 1

IF (I .NE. 3) THEN

HCN_DISCR(PKNET,M,MODYR) = HCN_DISCR(PKNET,M,MODYR) - &

( HAFLOW(AI,MODYR) * PKSHR_ICAN )

HCN_DISCR(OPNET,M,MODYR) = HCN_DISCR(OPNET,M,MODYR) - &

( HAFLOW(AI,MODYR) * (1.-PKSHR_ICAN) )

ENDIF

ENDIF

ENDDO

! SPREAD DISCREPANCY IN EACH SEASON EVENLY BETWEEN EAST AND WEST

! AND ADJUST NODE DEMAND TO ACCOUNT FOR DISCREPANCY

PKDISCR = HCN_DISCR(PKNET,1,MODYR) + HCN_DISCR(PKNET,2,MODYR)

OPDISCR = HCN_DISCR(OPNET,1,MODYR) + HCN_DISCR(OPNET,2,MODYR)

DO M=1,2

HCN_DISCR(PKNET,M,MODYR) = PKDISCR / 2.

HCN_DISCR(OPNET,M,MODYR) = OPDISCR / 2.

! ADJUST HAFLOW BTWN 24-23

IF (M .EQ. 1) THEN

A=NODE_2ARC(24,23)

HAFLOW(A,MODYR) = HAFLOW(A,MODYR) + HCN_DISCR(PKNET,M,MODYR) + &

HCN_DISCR(OPNET,M,MODYR)

ENDIF

! ADJUST NODE_DMD FOR DISCR

I = TNODES-LNGNODES-2+M

NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + &

HCN_DISCR(PKNET,M,MODYR)

NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + &

HCN_DISCR(OPNET,M,MODYR)

NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + &

HCN_DISCR(PKNET,M,MODYR)

NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + &

HCN_DISCR(OPNET,M,MODYR)

YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + &

HCN_DISCR(PKNET,M,MODYR)

YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + &

HCN_DISCR(OPNET,M,MODYR)
ENDDO

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

! DETERMINE L48 NATIONAL DISCREPANCY IN THE PEAK AND OFFPEAK PERIODS

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

IF (MODYR .LT. LHISYR) THEN

HBAL_ITM(9,MODYR) = HBAL_ITM(9,MODYR) + DEL_DISCR9(MODYR)

HBAL_ITM(4,MODYR) = HBAL_ITM(4,MODYR) + DEL_DISCR4(MODYR)

HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR9(MODYR)

HBAL_ITM(8,MODYR) = HBAL_ITM(8,MODYR) - DEL_DISCR4(MODYR)

ELSE IF (MODYR .EQ. LHISYR) THEN

DO I=1,DNODES

HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR-1)

ENDDO

ENDIF

! SUM INTO NATIONAL PEAK AND OFFPEAK DISCREPANCY

PKDISCR = 0.0

OPDISCR = 0.0

NATDISCR = 0.0

! CANADIAN IMPORTS

DO I=1,NXMAPUS

IF (I .NE. 3) THEN

J = NODE_2ARC(CAN_XMAPUS(I,2),CAN_XMAPUS(I,1))

PKDISCR = PKDISCR + (HAFLOW(J,MODYR) * PKSHR_ICAN)

OPDISCR = OPDISCR + (HAFLOW(J,MODYR) * (1.-PKSHR_ICAN))

ENDIF

ENDDO

! L48 NA PRODUCTION

DO I=1,uSNODES

IF (SUPARRAY(I) .EQ. 1) THEN

PKDISCR = PKDISCR + (QSUP(I) * PKSHR_PROD(I))

OPDISCR = OPDISCR + (QSUP(I) * (1.-PKSHR_PROD(I)))

ENDIF

ENDDO

! LNG IMPORTS WHEN NOT FIXED

IF (.NOT.FIXLNGFLG) THEN

DO I=1,NLNGTER-3

A = NODE_2ARC(LNG_XMAP(I,2),LNG_XMAP(I,3))

PKDISCR = PKDISCR + FLOW(PKNET,A)

OPDISCR = OPDISCR + FLOW(OPNET,A)

ENDDO

ENDIF

! REMAINDER

NATDISCR = 0.0

DO I=1,DNODES

PKDISCR = PKDISCR - PFUEL(PKNET,I) + HNETWTH(I,MODYR) - &

NODE_DMD(PKNET,I)

OPDISCR = OPDISCR - PFUEL(OPNET,I) - HNETINJ(I,MODYR) - &

NODE_DMD(OPNET,I)

NATDISCR = NATDISCR + HBAL_ITM(I,MODYR)

ENDDO

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

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

DO I=1,DNODES

HBAL_ITM(I,MODYR) = HBAL_ITM(I,MODYR) - REGADJ

ENDDO
! DISTRIBUTE PEAK AND OFFPEAK DISCREPANCY OVER REGIONS, BY ADJUSTING

! ANNUAL REGIONAL DISCREPANCY

PKADJ = ((PKDISCR - OPDISCR) / FLOAT(DNODES) ) / 2.

DO I=1,DNODES

DISCR(PKNET,I,MODYR) = (HBAL_ITM(I,MODYR) / 2.) + PKADJ

DISCR(OPNET,I,MODYR) = HBAL_ITM(I,MODYR) - DISCR(PKNET,I,MODYR)

NODE_DMD(PKNET,I) = NODE_DMD(PKNET,I) + DISCR(PKNET,I,MODYR)

NODE_DMD(OPNET,I) = NODE_DMD(OPNET,I) + DISCR(OPNET,I,MODYR)

NODE_CDMD(PKNET,I) = NODE_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR)

NODE_CDMD(OPNET,I) = NODE_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR)

YEAR_CDMD(PKNET,I) = YEAR_CDMD(PKNET,I) + DISCR(PKNET,I,MODYR)

YEAR_CDMD(OPNET,I) = YEAR_CDMD(OPNET,I) + DISCR(OPNET,I,MODYR)

ENDDO

RETURN

END

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

!

! SET SHARE OF FLOWS ALONG PIPE ARCS ONLY

! PSHR

!

! STATUS:

!

! CALLED BY: HNGDOWN_TREE

!

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

SUBROUTINE XNGSHR_PIPE(NET,DEST,PSHR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

INTEGER*4 A ! ARC COUNTER

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 SRC, DEST ! NODE ID

INTEGER*4 NET ! PK/OP NETWORK ID

REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE

REAL*4 TPFLOW(NETWORK) ! HOLDS TOTAL FLOW ALONG PIPE

! ----------

TPFLOW(NET) = 0.0

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY

TPFLOW(NET) = TPFLOW(NET) + FLOW(PKNET,A)+ &

FLOW(OPNET,A)

ENDIF

ENDDO

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY

PSHR(NET,A) = (FLOW(PKNET,A)+FLOW(OPNET,A)) &

/ TPFLOW(NET)
ENDIF

ENDDO

RETURN

END

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

!

! SET VARIABLES NEEDED FOR FORECAST YEARS

! FLOW

! SHR

! HPFUEL_FAC (used to set PFUEL_FAC)

! ARC_PFUEL

!

! STATUS:

!

! CALLED BY: HNGTDM_ITM

!

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

SUBROUTINE HNGDOWN_TREE

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

include 'ngcdmdinc'

INTEGER*4 A ! ARC COUNTER

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 SRC, DEST ! NODE ID

INTEGER*4 NET, NET0 ! PK/OP NETWORK ID

INTEGER*4 L,STID ! COUNTER

INTEGER*4 CAPFLG ! FLAG TO CONTINUE CHK FOR FLO ADJ DUE TO CAP

INTEGER*4 CHKCHNG ! FLG TO ADJ FLOWS ON OTHER NET

INTEGER*4 CHKOLD ! FLG FROM PREV NET ADJ

INTEGER*4 CNT ! COUNTER TO PREVENT INF LOOP

REAL*4 PNODE_DMD(NETWORK) ! NODE DMD FOR PIPE ARCS

REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE

REAL*4 TPNODE_DMD ! ANNUAL NODE DMD FOR PIPE ARCS

REAL*4 THAFLOW ! TOTAL FLOW ALONG PIPE INTO NODE

REAL*4 NGSET_FLOWREM ! FUNCTION: SETS REMAINING FLOW ALONG ARC

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 FAC(DNODES) ! SEASONAL PK/OP NET NODE DMD SHARE

REAL*4 FLO_ADJ ! ADJUSTMENT TO HAFLOW FOR HIST YRS

! ----------

DO L=1,NPROC

DEST = PROC_ORD(L)

! ADD PIPEFUEL TO NODE_DMD AND SET PFUEL FACTOR (HPFUEL_FAC)

! SET HISTORICAL INTRAREG FLOW FACTOR (HFLO_FAC)

DO NET=1,NETWORK

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! ADD NET INJECTIONS TO OFFPEAK DMDS

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF ( (NET .EQ. PKNET) .AND. (SRC .GT. (TNODES+SNODES))) THEN

STID = SRC - (TNODES+SNODES)

NODE_DMD(OPNET,DEST) = NODE_DMD(OPNET,DEST) + &
HNETINJ(STID,MODYR)

ENDIF

ENDDO

! DEFINE INTRAREGIONAL FLOW FACTOR AND FLOWS

! HFLO_FAC = INTRA_FLO / NODE_DMD(W/O PF)

IF (DEST .LE. DNODES) THEN

IF (NET .EQ. PKNET) THEN

FAC(DEST) = NODE_DMD(PKNET,DEST) / &

(NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST))

ELSE

FAC(DEST) = NODE_DMD(OPNET,DEST) / &

(NODE_DMD(PKNET,DEST) + NODE_DMD(OPNET,DEST))

ENDIF

A = SNODE_2ARC(DEST,DEST)

INTRA_FLO(NET,DEST,MODYR) = FAC(DEST) * SAFLOW(A,MODYR)

HFLO_FAC(NET,DEST,MODYR) = INTRA_FLO(NET,DEST,MODYR) / &

NODE_DMD(NET,DEST)

ENDIF

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

! TEMPCODE: 09/03/97

INTRA_PFUEL(NET,DEST) = PFUEL(NET,DEST)

! TEMPCODE: 09/03/97

IF (NODE_DMD(NET,DEST)-PFUEL(NET,DEST) .GT. 0.) THEN

HPFUEL_FAC(NET,DEST,MODYR) = PFUEL(NET,DEST) / &

(NODE_DMD(NET,DEST) + FIXSUPIP(NET,DEST) - PFUEL(NET,DEST))

ELSE

HPFUEL_FAC(NET,DEST,MODYR) = 0.0

ENDIF

PNODE_DMD(NET) = NODE_DMD(NET,DEST)

! ADJUST NODE DMD TO BE NET OF SUPPLY AND STORAGE

! (NODE DMD FOR PIPE ARCS ONLY)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .GT. TNODES) THEN

PNODE_DMD(NET) = PNODE_DMD(NET) - FLOW(NET,A)

ENDIF

ENDDO

IF (NGDBGITR(4,6)) THEN

IF (PNODE_DMD(NET) .LE. -0.001) THEN

WRITE(NGOERR,*) 'ATTN1 HNGDOWN_TREE: NET,DEST,MODYR=', &

NET,DEST,MODYR,' PNODE_DMD= ',PNODE_DMD(NET)

ENDIF

ENDIF

ENDDO

! CHECK TOTAL HAFLOWS FOR PIPE ARCS AGAINST TOTAL PNODE_DMD

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

THAFLOW = 0.0

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN

THAFLOW = THAFLOW + HAFLOW(A,MODYR)

ENDIF

ENDDO

TPNODE_DMD = PNODE_DMD(PKNET)+PNODE_DMD(OPNET)

IF (NGDBGITR(4,6)) THEN

IF (ABS(TPNODE_DMD - THAFLOW) .GT. 0.01) THEN

WRITE(NGOERR,*) ' ATTN6 HNGDOWN_TREE: DEST,MODYR= ', &

DEST,MODYR,' TPNODE_DMD= ', TPNODE_DMD,' THAFLOW= ', &

THAFLOW

ENDIF
ENDIF

! ADJUST HAFLOW TO BETTER MATCH DEMANDS

!CCC IF (MODYR .EQ. LHISYR) THEN

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF ((SRC .GT. DNODES) .AND. (SRC .LE. (TNODES-LNGNODES-2))) THEN

THAFLOW = THAFLOW - HAFLOW(A,MODYR)

TPNODE_DMD = TPNODE_DMD - HAFLOW(A,MODYR)

ENDIF

ENDDO

IF (THAFLOW .GT. 0.0) THEN

FLO_ADJ = TPNODE_DMD / THAFLOW

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. DNODES) THEN

!CCC IF ( (SRC .LE. DNODES) .OR.

!CCC * ((DEST.GT.(TNODES-2)) .OR. (DEST.LE.TNODES))) THEN

HAFLOW(A,MODYR) = HAFLOW(A,MODYR) * FLO_ADJ

ENDIF

ENDDO

ENDIF

!CCC ENDIF

! DETERMINE SHARES AMONG PIPE ARCS ONLY FOR PK NETWORK

CALL HNGSHR_PIPE(PKNET,DEST,PSHR)

! SET PK FLOWS ALONG PIPE ARCS

ARC_1 = ARC_LOOP(PKNET,DEST,1)

ARC_2 = ARC_LOOP(PKNET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN

FLOW(PKNET,A) = PSHR(PKNET,A) * PNODE_DMD(PKNET)

ENDIF

ENDDO

! CHECK FLOWS AGAINST MAX EFF CAPACITY ON EACH NETWORK

! AND RESET FLOWS ALONG PIPE ARCS

CAPFLG = 1

CHKOLD = 1

NET = 0

CNT = 1

DO WHILE ((CAPFLG .EQ. 1) .AND. (CNT .LE. 5))

IF (NET .EQ. PKNET) THEN

NET = OPNET

NET0= PKNET

ELSE

NET = PKNET

NET0= OPNET

ENDIF

CALL HNGCHK_PIPFLO(NET,DEST,PNODE_DMD(NET),CHKCHNG)

IF ((CHKCHNG .EQ. 0) .AND. (CHKOLD .EQ. 0)) THEN

CAPFLG = 0

ELSE

CAPFLG = 1

CHKOLD = CHKCHNG
ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN

FLOW(NET0,A) = HAFLOW(A,MODYR) - FLOW(NET,A)

ENDIF

ENDDO

ENDIF

CNT = CNT + 1

ENDDO

IF (CAPFLG .EQ. 1) THEN

WRITE(NGOERR,*) 'ATTN2 HNGDOWN_TREE: MAX EFF CAP REACHED ', &

'ON ALL ARCS FOR NODE ',DEST,' ITR=',CURITR,' YEAR=',MODYR

ENDIF

! REDEFINE SHARES AMONG PIPE ARCS ONLY

CALL HNGSHR_PIPE(PKNET,DEST,PSHR)

CALL HNGSHR_PIPE(OPNET,DEST,PSHR)

! SET PFUEL ALONG PIPE ARCS

! SET SHR ALONG ALL INPUT ARCS

DO NET=1,NETWORK

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN

ARC_PFUEL(NET,A) = PSHR(NET,A) * &

(PFUEL(NET,DEST)-INTRA_PFUEL(NET,DEST))

ENDIF

IF (SRC.GT.TNODES.AND. SRC.LE.TNODES+SNODES) THEN

IF(SUPARRAY(SRC-TNODES).NE.0) THEN

IF (ARC_1.EQ.ARC_2) THEN

SHR(NET,A,MODYR) = 1.0

ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN

SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)

ENDIF

NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)

ENDIF

ELSE

IF (ARC_1.EQ.ARC_2) THEN

SHR(NET,A,MODYR) = 1.0

ELSEIF (NODE_DMD(NET,DEST).NE.0.0) THEN

SHR(NET,A,MODYR) = FLOW(NET,A) / NODE_DMD(NET,DEST)

ELSE

SHR(NET,A,MODYR) = SHR(NET,A,MODYR-1)

ENDIF

NODE_DMD(NET,SRC) = NODE_DMD(NET,SRC) + FLOW(NET,A)

ENDIF

! DETERMINE REMAINING FLOW ALONG ARCS

FLOW_REM(NET,A) = NGSET_FLOWREM(NET,A)

ENDDO

BKSTOP(NET,DEST) = 0.0

ENDDO

ENDDO
RETURN

END

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

!

! SET SHARE OF FLOWS ALONG PIPE ARCS ONLY

! PSHR

!

! STATUS:

!

! CALLED BY: HNGDOWN_TREE

!

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

SUBROUTINE HNGSHR_PIPE(NET,DEST,PSHR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

INTEGER*4 A ! ARC COUNTER

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 SRC, DEST ! NODE ID

INTEGER*4 NET ! PK/OP NETWORK ID

REAL*4 PSHR(NETWORK,ARCS) ! SHARE FOR FLOW ALONG PIPE

REAL*4 TPFLOW(NETWORK) ! HOLDS TOTAL FLOW ALONG PIPE

! ----------

TPFLOW(NET) = 0.0

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY

TPFLOW(NET) = TPFLOW(NET) + FLOW(NET,A)

ENDIF

ENDDO

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPE ARCS ONLY

IF (TPFLOW(NET).NE. 0.0) THEN

PSHR(NET,A) = FLOW(NET,A) / TPFLOW(NET)

ELSE

PSHR(NET,A) = 0.0

ENDIF

ENDIF

ENDDO

RETURN

END

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

!

! CHECK FLOWS AGAINST MAX EFFECTIVE CAPACITY FOR PIPE ARCS ONLY

! ON EACH NETWORK

!

! STATUS:

!

! CALLED BY: HNGDOWN_TREE
!

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

SUBROUTINE HNGCHK_PIPFLO(NET,DEST,PDMD,CHKCHNG)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 A ! COUNTERS

INTEGER*4 ARC_1,ARC_2 ! INPUT ARC COUNTERS

INTEGER*4 DEST, SRC ! NODE ON TREE (SOURCE OR DEST NODE)

INTEGER*4 CHNG, CHK ! FLAGS TO REDEFINE SHARES

INTEGER*4 CHKCHNG ! FLAGS IF ANY FLOW CHANGE WAS MADE

INTEGER*4 OLDFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHRF(OLD)

INTEGER*4 MAXFLG(ARCS) ! FLAG TO TRACK ARCS AT MAX SHR

REAL*4 NGSET_MAXFLO ! FUNCTION: SETS MAX FLOW ON ARC

REAL*4 SUMFLO ! TOTAL FLOWS NOT AT MAX

REAL*4 SUMMAX ! TOTAL FLOWS AT MAX

REAL*4 SUMREM ! TOTAL FLOWS REMAINING FOR DISTRIBUTION

REAL*4 TMAXFLO ! TOTAL MAX FLOW INTO NODE

REAL*4 PDMD ! NODE DMD FOR PIPE ARCS

REAL*4 DELTA ! FLOW ADJUSTMENT QUANTITY

REAL*4 UTZ ! UTILZ FOR SEASON

REAL*4 CMAX ! MAXIMUM AVAILABLE PIPEFLOW BY ARC

! ---------

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

! SET MAXIMUM FLOWS AND TOTAL FLOWS

TMAXFLO = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

OLDFLG(A) = 0.

MAXFLG(A) = 0.

MAXFLO(NET,A) = NGSET_MAXFLO(NET,A) ! FUNCTION

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY

!CC IF (NET .EQ. PKNET) THEN

!CC UTZ = PKUTZ(A)

!CC ELSE IF (NET .EQ. OPNET) THEN

!CC UTZ = OPUTZ(A)

!CC ENDIF

!CC CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A))

CMAX = AMIN1((HAFLOW(A,MODYR)), MAXFLO(NET,A))

TMAXFLO = TMAXFLO + CMAX

ENDIF

ENDDO

! CHECK IF TOTAL FLOWS LESS THAN MAXIMUM FLOWS

CHKCHNG = 0

IF (PDMD .LE. TMAXFLO+.001) THEN ! DMD < TMAXFLO

CHNG = 1

DO WHILE (CHNG .EQ. 1)

CHK = 0

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

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY

! CHECK IF ARC FLOW GREATER THAN MAX

IF (FLOW(NET,A) .GE. MAXFLO(NET,A)) THEN

DELTA = FLOW(NET,A) - MAXFLO(NET,A)

! SET FLOW = MAX FLOW

FLOW(NET,A) = MAXFLO(NET,A)

! ADJUST CORRESP OP FLOW

MAXFLG(A) = 1

IF (MAXFLG(A) .NE. OLDFLG(A)) THEN

CHK = 1

CHKCHNG = 1

OLDFLG(A) = MAXFLG(A)

ENDIF

ENDIF

ENDIF

ENDDO

! IF FLOWS HAVE BEEN ADJUSTED, NEED TO REALLOCATE OVER OTHER ARCS

IF (CHK .EQ. 1) THEN

SUMMAX = 0.0

SUMREM = 0.0

SUMFLO = 0.0

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY

IF (MAXFLG(A) .EQ. 0) THEN

SUMFLO = SUMFLO + FLOW(NET,A)

ELSE

SUMMAX = SUMMAX + FLOW(NET,A)

ENDIF

ENDIF

ENDDO

SUMREM = PDMD - (SUMFLO+SUMMAX)

! DISTRIBUTE OVER UNCONSTR ARCS

DO A=ARC_1,ARC_2 ! LOOP OVER INPUT ARCS

SRC = ARC_2NODE(A,1)

IF (SRC .LE. TNODES) THEN ! PIPELINE ARCS ONLY

IF (MAXFLG(A) .EQ. 0) THEN

IF (SUMFLO .GT. 0.) THEN

DELTA = (SUMREM * (FLOW(NET,A) / SUMFLO))

ELSE

DELTA = 0.0

ENDIF

! SET FLOW = MAX FLOW

FLOW(NET,A) = FLOW(NET,A) + DELTA

! ADJUST CORRESP OP FLOW

ENDIF

ENDIF

ENDDO

ELSE

CHNG = 0

ENDIF

ENDDO

ELSE ! DMD GREATER THAN EFFECTIVE CAPACITY

IF (NGDBGITR(4,6)) THEN

WRITE(NGOERR,*) 'ATTN3 NGCHK_MAXFLO: PIPE DMD > MAX EFF CAP ', &

'FOR NET,NODE,ITR,YEAR:',NET,DEST,CURITR,MODYR, &

' PNDOE_DMD, MAX: ', PDMD, TMAXFLO

ENDIF

ENDIF
RETURN

END

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

!

! SET SUPPLY WELLHEAD PRICES BY REGION AND PEAK

!

! STATUS: COMPLETE

!

! CALLED BY: HNGTDM_ITM

!

! CALLS : NGSET_SUPPR

!

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

SUBROUTINE HNGSET_SUPPR

IMPLICIT NONE

include 'parametr'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

INTEGER*4 N,S ! COUNTERS

INTEGER*4 NET ! NETWORK ID (1=PK, 2=OP)

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

DO NET=1,NETWORK

DO N=1,NODES

NODE_ENDPR(NET,N) = 0.0

NODE_SHRPR(NET,N) = 0.0

ENDDO

ENDDO

DO NET=1,NETWORK

DO S=1,SNODES

N = TNODES + S

IF (SUPARRAY(S).EQ.1) NODE_QSUP(NET,S) = NODE_DMD(NET,N)

ENDDO

ENDDO

! SET SUPPLY PRICE BASED ON QTY GENERATED DOWN TREE

CALL NGSET_SUPPR

DO NET=1,NETWORK

DO S=1,SNODES

IF (SUPARRAY(S).EQ.1) THEN

N = TNODES + S

NODE_ENDPR(NET,N) = NODE_PSUP(NET,S)

NODE_SHRPR(NET,N) = NODE_PSUP(NET,S)

NODE_PSUPPREV(NET,S) = NODE_PSUP(NET,S)

NODE_QSUPPREV(NET,S) = NODE_QSUP(NET,S)

ENDIF

ENDDO

ENDDO

RETURN

END

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

!

! SET BENCHMARK FACTORS FOR CITYGATE, MEX, LNG PRICES

! AND SET CITYGATE PRICES FOR EACH PK/OP NETWORK

!
! STATUS: COMPLETE

!

! CALLED BY: HNGTDM_ITM

!

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

SUBROUTINE HNGSET_CGPR

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'nghistinc'

include 'ngptmitm'

include 'ogglobal'

INTEGER*4 N ! DEMAND NODES

INTEGER*4 NET ! REPRESENTS PK/OP NETWORKS

REAL*4 NGPIPE_VARTAR ! FUNCTION (from ptm)

REAL*4 TEMP ! TEMPORARILY HOLD INTRA VARTAR

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

DO N=1,DNODES ! LOOP OVER END-USE DEMAND NODES

DO NET=1,NETWORK ! LOOP OVER PK/OP NETWORKS

INTRAREG_TAR(NET,N) = INTRAREG_FIXTAR(NET,N) + &

NGPIPE_VARTAR(NET,NARCS+N,INTRA_FLO(NET,N,MODYR)) ! PTM function

!CCC TEMP = INTRAREG_TAR(NET,N) - INTRAREG_FIXTAR(NET,N)

!CCC WRITE(4,1000) MODYR,NET,N,INTRAREG_FIXTAR(NET,N),

!CCC * TEMP,INTRAREG_TAR(NET,N),INTRA_FLO(NET,N,MODYR)

!1000 FORMAT(' INTRAH',I4,2I3,3F6.3,F10.2)

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

INTRAST_TAR(N)

HCG_BENCH(NET,N,MODYR) = HCGPR(NET,N,MODYR) - CGPR(NET,N)

CGBENCH(NET,N) = HCG_BENCH(NET,N,MODYR)

ENDDO

ENDDO

CALL NGDBUG_DTM03(0)

RETURN

END

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

!

! SUBROUTINE TO RESET PREVIOUS YEAR'S SHARES IN ANTICIPATION OF

! PLANED CAPACITY BUILDS

!

! STATUS: COMPLETE

!

! CALLED BY: NGMAIN

!

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

SUBROUTINE NGPCAP_ADJSHR

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngtdminc'

include 'ngitminc'

include 'ngcdmdinc'
include 'ngakinc'

include 'ogglobal'

INTEGER*4 NET ! REPRESENTS PK, OP NETWORK

INTEGER*4 A,A2,I ! COUNTER

INTEGER*4 ARC_0 ! ARC FROM CANADA W/ANGTS FLOW

INTEGER*4 ARC_1 ! FIRST ARC INTO DEST

INTEGER*4 ARC_2 ! LAST ARC INTO DEST

INTEGER*4 DEST ! DESTINATION NODE INDEX

INTEGER*4 SRC ! SOURCE NODE INDEX

INTEGER*4 AKPIP ! SET TO 1 IF CH IN ANGTS VOLS, ELSE 0

INTEGER*4 A16,A17,A9 ! ARCS FOR 16->4 AND 17->4 AND 9->12

INTEGER*4 SRG ! SUPPLY REGION 1-20

INTEGER*4 ORG ! OFFSHORE REGION 1-3

INTEGER*4 ASUP ! ARC CORRESPONDING TO SUPPLY CURVE BEING ADJUSTED

REAL*4 SHRSUM ! SUM OF ADJUSTED SHARES INTO A NODE

REAL*4 TOTFLW ! LAST YEAR'S TOTAL FLOW INTO A NODE

REAL*4 CHQAK_ALB ! ANNUAL CHANGE IN ANGTS VOLUMES

REAL*4 PRDEXP ! INITAL GUESS AT BIG INCREASE IN PRODUCTION LEVELS (EXPECTED 

PRODUCTION)

REAL*4 PRDEXPLAG ! PRDEXP LAGGED

REAL*4 PRDCHG ! RATIO OF THIS YEAR TO LAST YEAR'S EXPECTED PRODUCTION

REAL*4 SHR1617 ! SUM OF REVISED SHARES FR 16->4 AND 17->4

REAL*4 FLDEL16,FLDEL17,FLDEL18,FLDEL19 ! EST INCR IN FLW ON BRD ARCS ATTRIBUTED 

TO ANGTS

LOGICAL ONCE ! SET TO FALSE IF RESERVES START IN ATLANTIC OFFSHORE

DATA ONCE /.TRUE./

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

! SET ANGTS VOLUME INCREASE

CHQAK_ALB = QAK_ALB(MODYR) - QAK_ALB(MODYR-1) + QMD_ALB(MODYR) - QMD_ALB(MODYR-1)

! ADJUSTMENT FOR ARCS NOT RELATED TO ANGTS

DO NET=1,NETWORK

DO A=1,NARCS

SRC = ARC_2NODE(A,2)

DEST = ARC_2NODE(A,1)

IF ( (DEST.LE.DNODES .OR. DEST.EQ.23 .OR. DEST.EQ.24) .AND. & !YD1LNG: LNG 

ARCS WILL BE ADJSUTED HERE

(ACTPCAP(A)+PLANPCAP(A,MODYR)).GT.0.001 ) THEN

IF ( CHQAK_ALB.LE.0.001 .OR. &

SRC.GT.(DNODES+NXMAPCN) .OR. SRC.LE.(DNODES+3) ) THEN

IF (SHR(NET,A,MODYR-1).GE.0.00001) THEN

SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * &

( ACTPCAP(A) + (PLANPCAP(A,MODYR)*PCTADJSHR) ) / ACTPCAP(A)

ELSE

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

TOTFLW = 0.0

DO A2 = ARC_1,ARC_2

TOTFLW = TOTFLW + FLOW(NET,A2)

ENDDO

SHR(NET,A,MODYR-1) = (PLANPCAP(A,MODYR)*0.15) / TOTFLW ! YD1 (REALLY 

JBE) INITIALIZE LNG IF ZERO

ARC_SHRPR(NET,A) = NODE_SHRPR(NET,DEST)

ENDIF

ENDIF

ENDIF

ENDDO

DO DEST=1,DNODES ! SCALE SO SUM SHARES ADDS TO ONE

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

IF (ARC_1 .EQ. ARC_2) THEN ! SINGLE ARC INTO NODE

SHR(NET,ARC_1,MODYR-1) = 1.0

ELSE

SHRSUM = 0.0

DO A=ARC_1,ARC_2

SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)

ENDDO

DO A = ARC_1,ARC_2

SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM

ENDDO

ENDIF

ENDDO

! ADJUSTMENT IF ANGTS OR MACKENZIE DELTA COME ON

IF (CHQAK_ALB .GT. 0.0000001) THEN

TOTFLW = 0.0

DO I=4,NXMAPUS

SRC = CAN_XMAPUS(I,2)

DEST = CAN_XMAPUS(I,1)

A = NODE_2ARC(SRC,DEST)

TOTFLW = TOTFLW + FLOW(NET,A)

ENDDO

! 80 PERCENT INITIAL US VS CANADA DISPLACEMENT

! EM4 TRACK -- keep here

FLDEL16 = (FLOW(NET,NODE_2ARC(16,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00

FLDEL17 = (FLOW(NET,NODE_2ARC(17,4))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00

FLDEL18 = (FLOW(NET,NODE_2ARC(18,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00

FLDEL19 = (FLOW(NET,NODE_2ARC(19,9))/TOTFLW) * CHQAK_ALB * SHRYR(NET) * 1.00

DEST = 4

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

TOTFLW = 0.0

SHRSUM = 0.0

DO A=ARC_1,ARC_2

SRC = ARC_2NODE(A,1)

TOTFLW = TOTFLW + FLOW(NET,A)

IF (SRC.NE.16 .AND. SRC.NE.17) SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)

ENDDO

A16 = NODE_2ARC(16,4)

SHR(NET,A16,MODYR-1) = ( FLOW(NET,A16) + FLDEL16) / TOTFLW

SHR(NET,A16,MODYR-1) = AMIN1(SHR(NET,A16,MODYR-1),1.0)

A17 = NODE_2ARC(17,4)

SHR(NET,A17,MODYR-1) = ( FLOW(NET,A17) + FLDEL17) / TOTFLW

SHR(NET,A17,MODYR-1) = AMIN1(SHR(NET,A17,MODYR-1),1.0)

SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1)

IF (SHR1617.GT.1.0) THEN

SHR(NET,A16,MODYR-1) = SHR(NET,A16,MODYR-1) / SHR1617

SHR(NET,A17,MODYR-1) = SHR(NET,A17,MODYR-1) / SHR1617

SHR1617 = SHR(NET,A16,MODYR-1) + SHR(NET,A17,MODYR-1)

ENDIF

DO A=ARC_1,ARC_2

IF (A.NE.A16 .AND. A.NE.A17) THEN

SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR1617) / SHRSUM

ENDIF

ENDDO

DEST = 12

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

TOTFLW = 0.0

SHRSUM = 0.0

DO A=ARC_1,ARC_2
SRC = ARC_2NODE(A,1)

TOTFLW = TOTFLW + FLOW(NET,A)

IF (SRC.NE.9) SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)

ENDDO

A9 = NODE_2ARC(9,12) ! INITIAL ASSUME 60 PERCENT ANGTS FLOW THRU FR 

9 TO 12

! EM4 TRACK -- keep here

SHR(NET,A9,MODYR-1) = ( FLOW(NET,A9) + ((FLDEL18+FLDEL19)*1.00) ) / TOTFLW

SHR(NET,A9,MODYR-1) = AMIN1(SHR(NET,A9,MODYR-1),1.0)

DO A=ARC_1,ARC_2

IF (A.NE.A9) THEN

SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) * (1.-SHR(NET,A9,MODYR-1)) / SHRSUM

ENDIF

ENDDO

ENDIF

ENDDO

! ADJUST LAST YEAR'S SHARES IF EXPECTED PRODUCTION BECOMES POSITIVE OR CHANGES 

SIGNIFICANTLY

DO SRG =1,NSUPSUB+NOCSREG

IF (SRG.LE.NSUPSUB) THEN

PRDEXP = oOGRESNGON(SRG,CURIYR) * oOGPRRNGON(SRG,CURIYR) ! "Z" ARRAYS NOT SET 

YET

PRDEXPLAG = oOGRESNGON(SRG,CURIYR-1) * oOGPRRNGON(SRG,CURIYR-1)

IF (PRDEXPLAG.GT.0.0) THEN

PRDCHG = PRDEXP / PRDEXPLAG

ELSE

PRDCHG = 1.0

ENDIF

ELSE

ORG = SRG-NSUPSUB

PRDEXP = oOGRESNGOF(ORG,CURIYR) * oOGPRRNGOF(ORG,CURIYR) ! "Z" ARRAYS NOT SET 

YET

PRDEXPLAG = oOGRESNGOF(ORG,CURIYR-1) * oOGPRRNGOF(ORG,CURIYR-1)

IF (PRDEXPLAG.GT.0.0) THEN

PRDCHG = PRDEXP / PRDEXPLAG

ELSE

PRDCHG = 1.0

ENDIF

ENDIF

IF ( (PRDEXP.GT.0.00001 .AND. PRDEXPLAG.LE.0.00001) .OR. PRDCHG.GE.1.2 .OR. 

PRDCHG.LE.0.8) THEN

DEST = MAP_NG(SRG)

ASUP = NODE_2ARC(TNODES+SRG,DEST)

DO NET=1,NETWORK

TOTFLW = 0.0

ARC_1 = ARC_LOOP(NET,DEST,1)

ARC_2 = ARC_LOOP(NET,DEST,2)

DO A=ARC_1,ARC_2

TOTFLW = TOTFLW + FLOW(NET,A)

ENDDO

SHR(NET,ASUP,MODYR-1) = PRDEXP*SHRYR(NET) / TOTFLW

SHRSUM = 0.0

DO A=ARC_1,ARC_2

SHRSUM = SHRSUM + SHR(NET,A,MODYR-1)

ENDDO

DO A=ARC_1,ARC_2

SHR(NET,A,MODYR-1) = SHR(NET,A,MODYR-1) / SHRSUM

ENDDO

ENDDO

ENDIF

ENDDO
RETURN

END

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

!

! WRITE CITYGATE PRICES AND COMPONENTS TO NGODTM DEBUG FILE

!

! STATUS: COMPLETE

!

! CALLED BY: NGTDM_ITM

!

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

SUBROUTINE NGDBUG_DTM03(YR)

IMPLICIT NONE

include 'parametr'

include 'ncntrl'

include 'ngparinc'

include 'ngitminc'

include 'ngtdminc'

include 'ngptmitm'

include 'nghistinc'

include 'ogglobal'

INTEGER*4 NET ! REPRESENTS PK,OP NETWORK

INTEGER*4 N,NREG ! REGION ID

INTEGER*4 YR ! HIST/FORE YR FLAG (0=HIST, 1=FORE)

INTEGER*4 J,I ! REG COUNTERS

INTEGER*4 TNET ! REPRESENTS ANNUAL

REAL*4 TRES_COM ! TOTAL RES+COM END_USE DEMAND

REAL*4 TEND_USE ! TOTAL END_USE DEMAND

REAL*4 YRSHR ! PK/OP DMD SHRS

REAL*4 YRSHR_F ! PK/OP UTIL FIRM DMD SHRS

REAL*4 YRSHR_I ! PK/OP UTIL INTR DMD SHRS

REAL*4 TMP_END_USE(DNODES) ! HOLDS PK END-USE DMDS

REAL*4 TMP_RES_COM(DNODES) ! HOLDS PK RES+COM DMDS

REAL*4 AEND_USE(DNODES) ! ANNUAL END-USE DMDS

REAL*4 ACGPR_END_USE(DNODES) ! ANNUAL CITYGATE PR (WT END-USE)

! ----------

IF (NGDBGITR(1,3)) THEN

WRITE(NGODTM,100)

ENDIF

DO NET=1,NETWORK

DO N=1,DNODES

TRES_COM = 0.0

TEND_USE = 0.0

DO I=1,DSEC-1

IF (NET .EQ. PKNET) THEN

YRSHR = PKSHR_DMD(I,N)

ELSE

YRSHR = 1.-PKSHR_DMD(I,N)

ENDIF

TEND_USE = TEND_USE+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N))

IF (I.EQ.1 .OR. I.EQ.2) THEN

TRES_COM = TRES_COM+ YRSHR* (ZNGQTY_F(I,N)+ ZNGQTY_I(I,N))

ENDIF

ENDDO

DO J=1,NNGEM-1

NREG=EMMSUB_NG(J)

IF (NREG .EQ. N) THEN

IF (NET .EQ. PKNET) THEN
YRSHR_F = PKSHR_UDMD_F(J)

YRSHR_I = PKSHR_UDMD_I(J)

ELSE

YRSHR_F = 1. - PKSHR_UDMD_F(J)

YRSHR_I = 1. - PKSHR_UDMD_I(J)

ENDIF

TEND_USE = TEND_USE + (YRSHR_F* ZNGUQTY_F(J)) + &

(YRSHR_I* ZNGUQTY_I(J))

ENDIF

ENDDO

IF (NGDBGITR(1,3)) THEN

IF (YR.EQ.0) THEN ! HISTORICAL YEAR

WRITE(NGODTM,110) MODYR,CURITR, NET, N, &

HCGPR(NET,N,MODYR), NODE_ENDPR(NET,N), &

INTRAREG_TAR(NET,N), INTRAST_TAR(N), &

CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), &

TEND_USE, TRES_COM

ELSE ! FORECAST YEAR

WRITE(NGODTM,110) MODYR,CURITR, NET, N, &

CGPR(NET,N), NODE_ENDPR(NET,N), &

INTRAREG_TAR(NET,N), INTRAST_TAR(N), &

CGBENCH(NET,N),INTRA_FLO(NET,N,MODYR), &

TEND_USE, TRES_COM

ENDIF

ENDIF

IF (NET .EQ. PKNET) THEN

TMP_END_USE(N) = TEND_USE

TMP_RES_COM(N) = TRES_COM

ELSE

IF (YR.EQ.0) THEN ! HISTORICAL YEAR

AEND_USE(N) = TMP_END_USE(N) + TEND_USE

ACGPR_END_USE(N) = ((HCGPR(PKNET,N,MODYR)*TMP_END_USE(N))+ &

(HCGPR(OPNET,N,MODYR)*TEND_USE)) / AEND_USE(N)

oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM

oACGPR_RESCOM(N,CURIYR) = ((HCGPR(PKNET,N,MODYR)*TMP_RES_COM(N))+ &

(HCGPR(OPNET,N,MODYR)*TRES_COM)) / oARESCOM(N,CURIYR)

ELSE ! FORECAST YEAR

AEND_USE(N) = TMP_END_USE(N) + TEND_USE

ACGPR_END_USE(N) = ((CGPR(PKNET,N)*TMP_END_USE(N)) + &

(CGPR(OPNET,N)*TEND_USE)) / AEND_USE(N)

oARESCOM(N,CURIYR) = TMP_RES_COM(N) + TRES_COM

oACGPR_RESCOM(N,CURIYR) = ((CGPR(PKNET,N)*TMP_RES_COM(N)) + &

(CGPR(OPNET,N)*TRES_COM)) / oARESCOM(N,CURIYR)

ENDIF

AVG_CGPR(N,MODYR) = ACGPR_END_USE(N)

ENDIF

ENDDO

ENDDO

! PUT INTO REPORT VARIABLES NGCGPR(REG,YR), NGNODDMD(REG,YR), NGENDDMD(REG,YR)

! NOTE: 'REGIONS' 13,14,15 ARE CDs 5,8,9 (for reporting)

DO N=1,DNODES

NGNODDMD(N,CURIYR) = 0.0

NGCGPR(N,CURIYR) = ACGPR_END_USE(N)

NGENDDMD(N,CURIYR) = AEND_USE(N)

DO NET=1,NETWORK

NGNODDMD(N,CURIYR) = NGNODDMD(N,CURIYR) + &

NODE_DMD(NET,N)

ENDDO

IF (N .EQ. 5) THEN ! combine ngreg 5&10 into CD 5
NGCGPR(DNODES+1,CURIYR) = ( (ACGPR_END_USE(10)*AEND_USE(10)) + &

(ACGPR_END_USE(N) *AEND_USE(N))) / &

(AEND_USE(10) + AEND_USE(N))

NGENDDMD(DNODES+1,CURIYR) = AEND_USE(10) + AEND_USE(N)

NGNODDMD(DNODES+1,CURIYR) = 0.0

DO NET=1,NETWORK

NGNODDMD(DNODES+1,CURIYR) = NGNODDMD(DNODES+1,CURIYR) + &

NODE_DMD(NET,10) + NODE_DMD(NET,N)

ENDDO

ELSE IF (N .EQ. 8) THEN ! combine ngreg 8&11 into CD 8

NGCGPR(DNODES+2,CURIYR) = ( (ACGPR_END_USE(11)*AEND_USE(11)) + &

(ACGPR_END_USE(N) *AEND_USE(N))) / &

(AEND_USE(11) + AEND_USE(N))

NGENDDMD(DNODES+2,CURIYR) = AEND_USE(11) + AEND_USE(N)

NGNODDMD(DNODES+2,CURIYR) = 0.0

DO NET=1,NETWORK

NGNODDMD(DNODES+2,CURIYR) = NGNODDMD(DNODES+2,CURIYR) + &

NODE_DMD(NET,11) + NODE_DMD(NET,N)

ENDDO

ELSE IF (N .EQ. 9) THEN ! combine ngreg 9&12 into CD 9

NGCGPR(DNODES+3,CURIYR) = ( (ACGPR_END_USE(12)*AEND_USE(12)) + &

(ACGPR_END_USE(N) *AEND_USE(N))) / &

(AEND_USE(12) + AEND_USE(N))

NGENDDMD(DNODES+3,CURIYR) = AEND_USE(12) + AEND_USE(N)

NGNODDMD(DNODES+3,CURIYR) = 0.0

DO NET=1,NETWORK

NGNODDMD(DNODES+3,CURIYR) = NGNODDMD(DNODES+3,CURIYR) + &

NODE_DMD(NET,12) + NODE_DMD(NET,N)

ENDDO

ENDIF

ENDDO

IF (NGDBGITR(1,3)) THEN

WRITE(NGODTM,120)

DO N=1,DNODES

TNET = 0

WRITE(NGODTM,130) MODYR,CURITR, TNET, N, &

ACGPR_END_USE(N), AEND_USE(N), &

oACGPR_RESCOM(N,CURIYR), oARESCOM(N,CURIYR)

ENDDO

ENDIF

100 FORMAT(1X,'DTM03: YEAR ITR NET NOD CGPRICE = NODEPR + ', &

'INTRAREG + INTRAST + CGBENCH INTRA_FLO END_USE_DMD', &

' RES+COM_DMD')

110 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3, &

F10.3,3F14.1)

120 FORMAT(1X,'DTM03: YEAR ITR NET NOD CGPR_END QEND_USE ', &

' CGPR_R+C QRES+COM')

130 FORMAT(1X,'DTM03: ',I4,I4,I4,I4,F10.3,F10.3,F10.3,F10.3)

RETURN

END