C $Header: /output/pkc/source/RCS/ind.f,v 1.153 1997/09/30 16:56:53 th4 Exp $
C
C  NEMS INDUSTRIAL MODULE  
C
C  ORDER OF INDUSTRIES:
C
C  NON-MANUFACTURING
C  1  AGRICULTURE - CROPS
C  2  AGRICULTURE - OTHER
C  3  COAL MINING
C  4  OIL AND GAS MINING
C  5  METAL AND OTHER NON-METALLIC MINING
C  6  CONSTRUCTION
C  MANUFACTURING
C  7  FOOD AND KINDRED PRODUCTS  (SIC 20)
C  8   PAPER AND ALLIED PRODUCTS  (SIC 26)
C  9 CHEMICALS AND ALLIED PRODUCTS  (SIC 28)
C         INORGANIC CHEMICALS  (SIC 281)
C         ORGANIC CHEMICALS  (SIC 286)
C         PLASTIC MATERIALS AND SYNTHETICS  (SIC 282)
C         AGRICULTURAL CHEMICALS (SIC 287)
C      .  OTHER CHEMICALS
C***
C*** COMBINE 281, 282, 286, 287 TO CREATE THE BULK CHEMICALS
C*** INDUSTRY===INDUSTRY 9
C***
C  STONE,CLAY, AND GLASS PRODUCTS  (SIC 32)
C    10   GLASS AND GLASS PRODUCTS  (SIC 321,322,323)
C    11   CEMENT, HYDRAULIC  (SIC 324)
C  PRIMARY METALS INDUSTRIES  (SIC 33)
C    12   IRON AND STEEL INDUSTRY
C    13   ALUMINUM INDUSTRY
C    14   METALS-BASED DURABLES  (SICs 34-38)
C    15  OTHER NON-INTENSIVE MFG
C
C  ORDER OF ENERGY SOURCES: (NOT FOR BUILDINGS)
C
C  THE MAIN QUANTITY ARRAY:  QTYMAIN(22,5)
C   1.  ELECTRICITY - (FROM PA AND BLD COMPONENTS)
C   2.              - Not Used
C   3.  NATURAL GAS - CORE (NEC) (FROM PA AND BLD COMPONENTS)
C   4.              - NONCORE (FROM BSC COMPONENT)
C   5.              - FEEDSTOCK
C   6.              - LEASE & PLANT
C   7.  COAL        - STEAM COAL
C   8.              - COKING COAL
C   9.              - COAL COKE (THIS IS NET COAL COKE IMPORTS)
C  10.  PETROLEUM   - RESIDUAL OIL
C  11.              - DISTILLATE OIL
C  12.              - LPGS FOR HEAT AND POWER
C  13.              - LPGS FOR FEEDSTOCKS
C  14.              - MOTOR GASOLINE
C  15.              - STILL GAS
C  16.              - PETROLEUM COKE
C  17.              - ASPHALT & ROAD OIL
C  18.              - LUBES & WAXES
C  19.              - PETROCHEMICAL FEEDSTOCKS
C  20.              - KEROSENE
C  21.              - OTHER PETROLEUM FEEDSTOCKS
C  22.              - OTHER PETROLEUM
C  THE INTERMEDIATE PRODUCTS QUANTITY ARRAY:  QTYINTR(6,5)
C   1.  STEAM                           (31)
C   2.  COKE OVEN GAS                   (32)
C   3.  BLAST FURNACE GAS               (33)
C   1.  OTHER BYPRODUCT GAS             (34)
C   2.  WASTE HEAT                      (35)
C   3.  COKE                            (36)
C  THE RENEWABLES QUANTITY ARRAY:  QTYRENW(8,5)
C   1.  HYDROPOWER                      (41)
C   2.  BIOMASS-WOOD                    (42)
C   3.  BIOMASS-PULPING LIQUOR          (43)
C   4.  GEOTHERMAL                      (44)
C   5.  SOLAR                           (45)
C   6.  PHOTOVOLTAIC                    (46)
C   7.  WIND                            (47)
C   8.  MUNICIPAL SOLID WASTE           (48)
C****
C  ENERGY SOURCES FOR BUILDINGS: (USED IN THE INPUT FILE ENPROD)
C
C   1.  ELECTRICITY
C   2.  NATURAL GAS
C   3.  STEAM

C****
C  VINTAGES:
C
C  VARIABLES ARE DIMENSIONED WITH 4 OR 3 VINTAGES.
C  1 = OLD (1990 AND EARLIER)
C  2 = MID (1991 TO OR THROUGH THE CURRENT FORECAST YEAR
C  3 = NEW (THE CURRENT FORECAST YEAR)
C  4 = ALL OR TOTAL
C****

C****
C  LAGS:
C****
C  SOME VARIABLES ARE DIMENSIONED FOR CURRENT YEAR AND LAG YEAR.
C  1 = CURRENT YEAR
C  2 = LAG YEAR
C  NOTE THAT THERE ARE ALSO SOME VARIABLES THAT ARE LAGGED
C  BY USING A DIFFERENT VARIABLE NAME.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE IND
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDMACRO)
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(MACOUT)
      INCLUDE(APQ)
      INCLUDE(QCENSUS)
      INCLUDE(EUSPRC)
      include(INDOUT)
      INTEGER IR,JYR,ID,IF,I,J,YR
      REAL DPRCX(30,11),E90PRCX(8),E91PRCX(8)
      REAL DCONX(30,11)

      DATA E90PRCX/5.87,5.69,4.03,3.22,2.82,1.81,1.51,18.03/
      DATA E91PRCX/ 5.05,5.59,3.42,2.63,3.19,1.77,1.5,17.69/
C******
C  ASSIGN YEAR PARAMETERS.
C******

      IYR=CURIYR+1989
      JYR=IYR-1989
      IBYR=FIRSYR+1989
      IEYR=LASTYR+1989

C******
C  ASSIGN ITERATION PARAMETERS.
C******

      FSTITER=CURITR
      LSTITER=FCRL
      IF(NCRL.EQ.1) THEN
        CALL INDUSREPORT
        RETURN
      ENDIF
C******
C  ASSIGN GROSS OUTPUT FOR EACH INDUSTRY.
C******

      DO 5 ID=1,11
        OUTIND(1,ID)=MC_MFGO(ID,30,JYR)/1000  !CROPS
        OUTIND(2,ID)=MC_MFGO(ID,31,JYR)/1000  !OTHER AGRI
        OUTIND(3,ID)=MC_MFGO(ID,32,JYR)/1000  !COAL MINING
        OUTIND(4,ID)=MC_MFGO(ID,33,JYR)/1000  !OIL & GAS MINING
        OUTIND(5,ID)=MC_MFGO(ID,34,JYR)/1000  !METAL & OTHER MINING
        OUTIND(6,ID)=MC_MFGO(ID,35,JYR)/1000  !CONSTRUCTION

        OUTIND(7,ID)=MC_MFGO(ID,1,JYR)/1000   !FOOD
        OUTIND(8,ID)=MC_MFGO(ID,7,JYR)/1000  !PAPER
        OUTIND(9,ID)=(MC_MFGO(ID,9,JYR)+
     1                MC_MFGO(ID,10,JYR)+
     1                MC_MFGO(ID,11,JYR)+
     1                MC_MFGO(ID,12,JYR))/1000 !BULK CHEMICALS

        OUTIND(10,ID)=MC_MFGO(ID,18,JYR)/1000  !GLASS
        OUTIND(11,ID)=MC_MFGO(ID,19,JYR)/1000  !CEMENT
        OUTIND(12,ID)=MC_MFGO(ID,21,JYR)/1000  !BLAST FURNACE
        OUTIND(13,ID)=MC_MFGO(ID,22,JYR)/1000  !PRIMARY ALUM
        OUTIND(14,ID)=MC_MFGO(ID,24,JYR)/1000  !METALS
     1 +              MC_MFGO(ID,25,JYR)/1000
     1 +              MC_MFGO(ID,26,JYR)/1000
     1 +              MC_MFGO(ID,27,JYR)/1000
     1 +              MC_MFGO(ID,28,JYR)/1000

                 !Other Non-Intensive Mfg
        OUTIND(15,ID)=MC_MFGO(ID,2,JYR)/1000   !tobacco
     1 +             MC_MFGO(ID,3,JYR)/1000    !textiles
     1 +             MC_MFGO(ID,4,JYR)/1000    !apparel
     1 +             MC_MFGO(ID,5,JYR)/1000    !lumber
     1 +             MC_MFGO(ID,6,JYR)/1000    !furniture
     1 +             MC_MFGO(ID,8,JYR)/1000    !printing
     1 +             MC_MFGO(ID,13,JYR)/1000   !other chemicals
     1 +             MC_MFGO(ID,15,JYR)/1000   !other sic 29
     1 +             MC_MFGO(ID,16,JYR)/1000   !rubber
     1 +             MC_MFGO(ID,17,JYR)/1000   !leather
     1 +             MC_MFGO(ID,20,JYR)/1000   !other scg
     1 +             MC_MFGO(ID,23,JYR)/1000   !other metals
     1 +             MC_MFGO(ID,29,JYR)/1000   !misc mfg

   5  CONTINUE
C******
C  ASSIGN OUTIND VALUES TO ARRAY INDMAC TO BE USED
C  IN CALGEN TO GROW COGENERATION POST maxplan (which isn't defined yet)
C******
       IF(IYR.GE.1997) THEN
        YR = IYR - 1996
        DO I = 1,15
          DO J = 1,9
            INDMAC(I,YR,J) = OUTIND(I,J)
          ENDDO
        ENDDO
       ENDIF
C******
C  ASSIGN EMPLOYMENT VALUES FOR EACH INDUSTRY.
C******
      DO 10 ID=1,11
        EMPIND(1,ID)=MC_EMPNA(ID,2,JYR)    !CONSTRUCTION
        EMPIND(2,ID)=MC_EMPNA(ID,5,JYR)    !MINING
        EMPIND(3,ID)=MC_EMPNA(ID,21,JYR)   !FOOD
        EMPIND(4,ID)=MC_EMPNA(ID,22,JYR)   !TOBACCO
        EMPIND(5,ID)=MC_EMPNA(ID,23,JYR)   !TEXTILE
        EMPIND(6,ID)=MC_EMPNA(ID,24,JYR)   !APPAREL
        EMPIND(7,ID)=MC_EMPNA(ID,11,JYR)   !LUMBER
        EMPIND(8,ID)=MC_EMPNA(ID,12,JYR)   !FURNITURE
        EMPIND(9,ID)=MC_EMPNA(ID,25,JYR)   !PAPER
        EMPIND(10,ID)=MC_EMPNA(ID,26,JYR)  !PRINTING
        EMPIND(11,ID)=MC_EMPNA(ID,27,JYR)  !CHEMICALS
        EMPIND(12,ID)=MC_EMPNA(ID,28,JYR)  !REFINING
        EMPIND(13,ID)=MC_EMPNA(ID,29,JYR)  !RUBBER
        EMPIND(14,ID)=MC_EMPNA(ID,30,JYR)  !LEATHER
        EMPIND(15,ID)=MC_EMPNA(ID,13,JYR)  !SCG
        EMPIND(16,ID)=MC_EMPNA(ID,14,JYR)  !PRIMARY METALS
        EMPIND(17,ID)=MC_EMPNA(ID,15,JYR)  !FAB METALS
        EMPIND(18,ID)=MC_EMPNA(ID,16,JYR)  !IND MACHINERY
        EMPIND(19,ID)=MC_EMPNA(ID,17,JYR)  !ELECTRONIC
        EMPIND(20,ID)=MC_EMPNA(ID,18,JYR)  !TRANSPORTATION
        EMPIND(21,ID)=MC_EMPNA(ID,19,JYR)  !INSTRUMENTS
        EMPIND(22,ID)=MC_EMPNA(ID,20,JYR)  !MISC MANUF
 10   CONTINUE

C  ASSIGN NEMS PRICES TO IND VARIABLES
      DO ID=1,11
        DPRCX(1,ID)=PELIN(ID,JYR)
        DPRCX(2,ID)=PELIN(ID,JYR)
        DPRCX(3,ID)=PGFIN(ID,JYR)
        DPRCX(4,ID)=PGIIN(ID,JYR)
        DPRCX(5,ID)=PGFIN(ID,JYR)
        DPRCX(6,ID)=PLPIN(ID,JYR)
        DPRCX(7,ID)=PCLIN(ID,JYR)
        DPRCX(8,ID)=PMCIN(ID,JYR)
        DPRCX(9,ID)=PMCIN(ID,JYR)
        DPRCX(10,ID)=PRLIN(ID,JYR)
        DPRCX(11,ID)=PDSIN(ID,JYR)
        DPRCX(12,ID)=PLGIN(ID,JYR)
        DPRCX(13,ID)=PLGIN(ID,JYR)
        DPRCX(14,ID)=PMGIN(ID,JYR)
        DPRCX(15,ID)=PRSIN(ID,JYR)
        DPRCX(16,ID)=PRSIN(ID,JYR)
        DPRCX(17,ID)=PRSIN(ID,JYR)
        DPRCX(18,ID)=PRSIN(ID,JYR)
        DPRCX(19,ID)=PRSIN(ID,JYR)
        DPRCX(20,ID)=PKSIN(ID,JYR)
        DPRCX(21,ID)=PRSIN(ID,JYR)
        DPRCX(22,ID)=PRSIN(ID,JYR)
c assign the "new" electricity prices according to which industry 
c  groups: Primary=food,paper,chemicals,steel,aluminum;
c          Shift  =metal based durables;
c          Miscellaneous =all the rest.
c first make sure the prices are not zero!  ****
      if(curiyr.eq.1) then
            if(pelinp(id,jyr).le.0)
     1         pelinp(id,jyr)=pelin(id,jyr)
            if(pelins(id,jyr).le.0)
     1         pelins(id,jyr)=pelin(id,jyr)
            if(pelinm(id,jyr).le.0)
     1         pelinm(id,jyr)=pelin(id,jyr)
      else 
            if(pelinp(id,jyr).le.0)
     1         pelinp(id,jyr)=pelinp(id,jyr-1)
            if(pelins(id,jyr).le.0)
     1         pelins(id,jyr)=pelins(id,jyr-1)
            if(pelinm(id,jyr).le.0)
     1         pelinm(id,jyr)=pelinm(id,jyr-1)
      endif
        DPRCX(23,ID)=PELINp(ID,JYR)
        DPRCX(24,ID)=PELINs(ID,JYR)
        DPRCX(25,ID)=PELINm(ID,JYR)
      ENDDO

C**
C  SET A MAXIMUM PRICE OF $50.0/BTU
C**
       DO IF=1,25
        DO ID=1,11
         IF(DPRCX(IF,ID).GE.50.0) DPRCX(IF,ID)=50.0
        ENDDO
       ENDDO
C******
C  AGGREGATE CENSUS DIVISION PRICES TO CENSUS REGION PRICES.
C  IF 1990, USE SEDS CONSUMPTION TO WEIGHT PRICES.
C  IF PAST 1990, USE LAG FORECAST CONSUMPTION.
C******
      IF(JYR.LE.MSEDYR) THEN
        IF(JYR.LE.MSEDYR) THEN
          I = JYR
        ELSE
          I = MSEDYR
        ENDIF
        DO ID=1,11
          DCONX(1,ID)=QSELIN(ID,I)
          DCONX(2,ID)=QSELIN(ID,I)
          DCONX(3,ID)=QSNGIN(ID,I)
          DCONX(4,ID)=QSNGIN(ID,I)
          DCONX(5,ID)=QSNGIN(ID,I)
          DCONX(6,ID)=QSLPIN(ID,I)
          DCONX(7,ID)=QSCLIN(ID,I)
          DCONX(8,ID)=QSMCIN(ID,I)
          DCONX(9,ID)=QSMCIN(ID,I)
          DCONX(10,ID)=QSRSIN(ID,I)
          DCONX(11,ID)=QSDSIN(ID,I)
          DCONX(12,ID)=QSLGIN(ID,I)
          DCONX(13,ID)=QSLGIN(ID,I)
          DCONX(14,ID)=QSMGIN(ID,I)
          DCONX(15,ID)=QSSGIN(ID,I)
          DCONX(16,ID)=QSPCIN(ID,I)
          DCONX(17,ID)=QSASIN(ID,I)
          DCONX(18,ID)=QSOTIN(ID,I)
          DCONX(19,ID)=QSPFIN(ID,I)
          DCONX(20,ID)=QSKSIN(ID,I)
          DCONX(21,ID)=QSOTIN(ID,I)
          DCONX(22,ID)=QSOTIN(ID,I)
          DconX(23,ID)=qELINp(ID,I)
          DconX(24,ID)=qELINs(ID,I)
          DconX(25,ID)=qELINm(ID,I)
        ENDDO
      ELSE
        DO ID=1,11
          DCONX(1,ID)=QELIN(ID,JYR-1)
          DCONX(2,ID)=QELIN(ID,JYR-1)
          DCONX(3,ID)=QGFIN(ID,JYR-1)
          DCONX(4,ID)=QGIIN(ID,JYR-1)
          DCONX(5,ID)=QGIIN(ID,JYR-1)
          DCONX(6,ID)=QLPIN(ID,JYR-1)
          DCONX(7,ID)=QCLIN(ID,JYR-1)
          DCONX(8,ID)=QMCIN(ID,JYR-1)
          DCONX(9,ID)=QMCIN(ID,JYR-1)
          DCONX(10,ID)=QRLIN(ID,JYR-1)
          DCONX(11,ID)=QDSIN(ID,JYR-1)
          DCONX(12,ID)=QLGIN(ID,JYR-1)
          DCONX(13,ID)=QLGIN(ID,JYR-1)
          DCONX(14,ID)=QMGIN(ID,JYR-1)
          DCONX(15,ID)=QSGIN(ID,JYR-1)
          DCONX(16,ID)=QPCIN(ID,JYR-1)
          DCONX(17,ID)=QASIN(ID,JYR-1)
          DCONX(18,ID)=QOTIN(ID,JYR-1)
          DCONX(19,ID)=QPFIN(ID,JYR-1)
          DCONX(20,ID)=QKSIN(ID,JYR-1)
          DCONX(21,ID)=QOTIN(ID,JYR-1)
          DCONX(22,ID)=QOTIN(ID,JYR-1)
          DconX(23,ID)=qELINp(ID,JYR-1)
          DconX(24,ID)=qELINs(ID,JYR-1)
          DconX(25,ID)=qELINm(ID,JYR-1)
        ENDDO
      ENDIF

      DO IF=1,25
        IF((DCONX(IF,1)+DCONX(IF,2)).GT.0.0) THEN
          PRCX(IF,1)=((DPRCX(IF,1)*DCONX(IF,1))+
     1                (DPRCX(IF,2)*DCONX(IF,2)))/
     1                 (DCONX(IF,1)+DCONX(IF,2))
        ELSE
          PRCX(IF,1)=(DPRCX(IF,1)+DPRCX(IF,2))/2.0
        ENDIF
        IF((DCONX(IF,3)+DCONX(IF,4)).GT.0.0) THEN
          PRCX(IF,2)=((DPRCX(IF,3)*DCONX(IF,3))+
     1                (DPRCX(IF,4)*DCONX(IF,4)))/
     1                 (DCONX(IF,3)+DCONX(IF,4))
        ELSE
          PRCX(IF,2)=(DPRCX(IF,3)+DPRCX(IF,4))/2.0
        ENDIF
        IF((DCONX(IF,5)+DCONX(IF,6)+DCONX(IF,7)).GT.0.0) THEN
          PRCX(IF,3)=((DPRCX(IF,5)*DCONX(IF,5))+
     1                (DPRCX(IF,6)*DCONX(IF,6))+
     1                (DPRCX(IF,7)*DCONX(IF,7)))/
     1                 (DCONX(IF,5)+DCONX(IF,6)+DCONX(IF,7))
        ELSE
          PRCX(IF,3)=(DPRCX(IF,5)+DPRCX(IF,6)+DPRCX(IF,7))/3.0
        ENDIF
        IF((DCONX(IF,8)+DCONX(IF,9)).GT.0.0) THEN
          PRCX(IF,4)=((DPRCX(IF,8)*DCONX(IF,8))+
     1                (DPRCX(IF,9)*DCONX(IF,9)))/
     1                 (DCONX(IF,8)+DCONX(IF,9))
        ELSE
          PRCX(IF,4)=(DPRCX(IF,8)+DPRCX(IF,9))/2.0
        ENDIF
      ENDDO

C******
C  ASSIGN NATIONAL PRICES.
C******
        PRCX(1,5)=PELIN(11,JYR)
        PRCX(2,5)=PELIN(11,JYR)
        PRCX(3,5)=PGFIN(11,JYR)
        PRCX(4,5)=PGIIN(11,JYR)
        PRCX(5,5)=PGFIN(11,JYR)
        PRCX(6,5)=PLPIN(11,JYR)
        PRCX(7,5)=PCLIN(11,JYR)
        PRCX(8,5)=PMCIN(11,JYR)
        PRCX(9,5)=PMCIN(11,JYR)
        PRCX(10,5)=PRLIN(11,JYR)
        PRCX(11,5)=PDSIN(11,JYR)
        PRCX(12,5)=PLGIN(11,JYR)
        PRCX(13,5)=PLGIN(11,JYR)
        PRCX(14,5)=PMGIN(11,JYR)
        PRCX(15,5)=PRSIN(11,JYR)
        PRCX(16,5)=PRSIN(11,JYR)
        PRCX(17,5)=PRSIN(11,JYR)
        PRCX(18,5)=PRSIN(11,JYR)
        PRCX(19,5)=PRSIN(11,JYR)
        PRCX(20,5)=PKSIN(11,JYR)
        PRCX(21,5)=PRSIN(11,JYR)
        PRCX(22,5)=PRSIN(11,JYR)
        PRCX(23,5)=PELINp(11,JYR)
        PRCX(24,5)=PELINs(11,JYR)
        PRCX(25,5)=PELINm(11,JYR)

C*****
C SET A MAXIMUM PRICE OF $50.0/BTU
C****
      DO IF=1,25
       IF(PRCX(IF,5).GE.50.0) PRCX(IF,5)=50.0
      ENDDO
C******
C  SAVE INPUT ENERGY PRICES.
C******

      DO 20 ID=1,11
        ENPRC(1,ID)=PEPIN(ID,JYR)           !PEAK ELECTRICITY
        ENPRC(2,ID)=PENIN(ID,JYR)           !NONPEAK ELEC
        ENPRC(3,ID)=PELIN(ID,JYR)           !ELECTRICITY
        ENPRC(4,ID)=PGFIN(ID,JYR)           !NGAS - FIRM
        ENPRC(5,ID)=PGIIN(ID,JYR)           !NGAS - INTERR.
        ENPRC(6,ID)=PNGIN(ID,JYR)           !NATURAL GAS
        ENPRC(7,ID)=PLPIN(ID,JYR)           !NGLP
        ENPRC(8,ID)=PCLIN(ID,JYR)           !COAL
        ENPRC(9,ID)=PMCIN(ID,JYR)           !METALLURGICAL COAL
        ENPRC(10,ID)=PMGIN(ID,JYR)           !MOTOR GASOLINE
        ENPRC(11,ID)=PDSIN(ID,JYR)           !DISTILLATE OIL
        ENPRC(12,ID)=PKSIN(ID,JYR)           !KEROSENE
        ENPRC(13,ID)=PLGIN(ID,JYR)           !LPG
        ENPRC(14,ID)=PRLIN(ID,JYR)           !RESIDUAL - LOW SULFUR
        ENPRC(15,ID)=PRSIN(ID,JYR)           !RESIDUAL
        ENPRC(16,ID)=POTIN(ID,JYR)           !OTHER PETROLEUM
        ENPRC(17,ID)=PTPIN(ID,JYR)           !TOTAL PETROLEUM
 20   CONTINUE

C****
C   SET A MAX PRICE OF $50.0/BTU
C****
      DO IF=1,17
       DO ID=1,11
         IF(ENPRC(IF,ID).GE.50.0) ENPRC(IF,ID)=50.0
       ENDDO
      ENDDO
C******
C  ASSIGN A BOGUS PRICE FOR BIOMASS FOR NOW BUT CHECK THIS!!
C******

      DO IR=1,5
        PRCX(42,IR)=2.0
      ENDDO

C******
C  STEAM PRICE WILL ULTIMATELY BE A QUANTITY WEIGHTED AVERAGE.
C  AVERAGE OF NATURAL GAS, RESIDUAL OIL AND COAL PRICES.
C******

      DO IR=1,5
        PRCX(31,IR)=(PRCX(4,IR)+PRCX(7,IR)+PRCX(10,IR))/3.0
      ENDDO
C******
C  ASSIGN 1991 PRICES FOR STORAGE
C******
      IF(IYR.EQ.1991) THEN
         DO IR = 1,4
           PRCX90(1,IR) = PRCX(4,IR)
           PRCX90(2,IR) = PRCX(7,IR)
           PRCX90(3,IR) = PRCX(10,IR)
         ENDDO
      ENDIF
      DO IF=1,50 
        DO IR=1,4
          PRCXYR(IF,IR,JYR)=PRCX(IF,IR)
        ENDDO
      ENDDO


C******
C  CALL THE INDUSTRIAL MODEL CALCULATIONS.
C******

      CALL ISEAM

C******
C  PASS THE RESULTS TO THE INTEGRATING SYSTEM.
C
C  WEXOG PASSES CONSUMPTION VALUES TO NEMS.
C  WEXOG ALSO SAVES ALL INPUT VALUES FROM NEMS TO A BINARY FILE.
C******

      CALL WEXOG

C******
C  FORMAT STATEMENTS USED IN SUBROUTINE.
C******

 902  FORMAT(1X,/)
 904  FORMAT(6X,11F8.1)
 905  FORMAT(6X,11F8.3)
 900  CONTINUE

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALLS ALL THE NECESSARY SUBROUTINES TO
C  RUN THE INDUSTRIAL MODEL.  THIS IS A CONTROL CENTER.
C******
      SUBROUTINE ISEAM
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
      INCLUDE(INDEBLK)
      INCLUDE(INDCOGEN)
C VARIABLES FOR BUFFERS TO HOLD ALTERNATIVE TO DIRECT ACCESS RECORDS
      INCLUDE(INDBFC1)
C******
C  DECLARATIONS FOR FILE MANAGER ROUTINE.
C******
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW

C******
C  DECLARE INTERNAL VARIABLES.
C******

      INTEGER IP,ID,IF,IPOLL,IREG,IR,J
      INTEGER IUNIT2R1,IUNIT2R2,IUNIT2R3,IUNIT2R4
      INTEGER IUNIT3R1,IUNIT3R2,IUNIT3R3,IUNIT3R4
c     REAL SHARE

C******
C  READ THE CONTROL VARIABLE FILE 
C  ONLY ON THE FIRST ITERATION OF THE FIRST YEAR MODEL RUN.
C******

      IF(IYR.EQ.IBYR.AND.FSTITER.EQ.1) THEN
        CALL RCNTL
      ENDIF

C******
C  OPEN A FILE FOR DEBUG WRITES.
C  ONLY IF INTERNAL DEBUG SWITCH IS ON, OR, IF SUBROUTINE
C  TRACE IS ON ,OR, IF WRITING SUMMARY RESULTS.
C  OPENING OF FILE IS DONE ON FIRST YEAR, FIRST ITERATION.
C  IF THE DEBUG FILE IS OPENED, A FLAG IS TURNED ON (IOPEN=1).
C******

      IF((IWDBG.EQ.1.OR.ISUBTR.EQ.1.OR.IWRSUM.EQ.1).AND.
     1   IYR.EQ.IBYR.AND.FSTITER.EQ.1) THEN
        FNAME=NFILE(3)
        NEW=.TRUE.
        IUNIT1=FILE_MGR('O',FNAME,NEW)
        IOPEN=1
      ENDIF

C******
C  WRITE SUBROUTINE TRACE INFORMATION, IF ON.
C******

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1   WRITE(IUNIT1,991)

C******
C  WRITE A HEADING IN THE DEBUG REPORT FILE.
C******

      IF(IWDBG.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1     WRITE(IUNIT1,801) IYR

C******
C  OPEN BINARY (UNFORMATTED) FILES USED AS RESTART FILES.
C  THERE ARE TWO TYPES OF RESTART FILES.  BOTH CHANGE INDUSTRY TO
C  INDUSTRY, BUT ONLY ONE CHANGES YEAR TO YEAR.
C  THESE FILES ARE OPENED ON THE FIRST YEAR, FIRST ITERATION.
C******
C
C  OPEN FILE INDBIN1 (CONSTANT FOR ALL YEARS).
C  OPEN FILE INDBIN2 (VARIABLE FOR EACH YEAR).
C******

      IF(IYR.EQ.IBYR.AND.FSTITER.EQ.1.AND.PRTDBGI.GE.1) THEN
        NEW=.TRUE.
        FNAME='INDBIN1'
        IUNIT2=FILE_MGR('O',FNAME,NEW)
        NEW=.TRUE.
        FNAME='INDBIN2'
        IUNIT3=FILE_MGR('O',FNAME,NEW)
      ENDIF
      IF(IYR.GT.IBYR.AND.FSTITER.EQ.1) THEN
        DO IR=1,4
          DO ID=1,NUMIND
            B2ILAG(ID,IR)=B2ICUR(ID,IR)
            IF(PRTDBGI.GE.1) WRITE(IUNIT3) B2ICUR(ID,IR)
          ENDDO
          DO IP=1,NUMPROC
            B2PLAG(IP,IR)=B2PCUR(IP,IR)
            IF(PRTDBGI.GE.1) WRITE(IUNIT3) B2PCUR(IP,IR)
          ENDDO
        ENDDO
      ENDIF

C******

C******
C       READ THE EXOGENOUS FORECAST INPUTS.
C******

      CALL REXOG

C*
C        MAKE ADJUSTMENTS TO ENERGY PRICES
C**

       IF(IPRICE.EQ.1.AND.IYR.GT.1995) CALL PRICE

C******
C  DO CALCULATIONS FOR EACH INDUSTRY.
C******

      DO 45 INDNUM=1,INDMAX

        DO IR=1,4

C******
C     THE FOLLOWING IS PERFORMED ON THE FIRST YEAR.
C******


C******
C  ON FIRST YEAR READ THE STEO and REFINERY FILES
C******

          IF(IYR.EQ.IBYR.AND.INDNUM.EQ.1.AND.IR.EQ.1) THEN
            CALL IRSTEO
          ENDIF

C******
C     OPEN THE PRODUCTION AND ENERGY FILE ENPROD.
C******

          IF(IYR.EQ.IBYR)THEN
            IF(INDNUM.EQ.1) THEN
              IF(IR.EQ.1) THEN
                FNAME=NFILE(1)
                NEW=.FALSE.
                IUNIT4=FILE_MGR('O',FNAME,NEW)
              ENDIF
            ENDIF

C******
C         READ PRODUCTION AND ENERGY DATA, ENPROD
C******

            CALL IEDATA

C******
C         CALCULATE BYPRODUCT ENERGY PRODUCED.
C******

c *** it will be convenient to call calbyprod after calpatot ***
c           CALL CALBYPROD

C******
C         CALCULATE ENERGY CONSUMPTION IN THE PROCESS AND
C            AND ASSEMBLY COMPONENT.
C******

            CALL CALPATOT
c *** it will be convenient to call calbyprod after calpatot ***
            CALL CALBYPROD

C******
C         CALCULATE ENERGY CONSUMPTION IN THE BUILDING
C            COMPONENT.
C******

            CALL CALBTOT

C******
C         CALCULATE ELECTRICITY GENERATED BY THE INDUSTRY
C            FOR OWN USE AND SALES.
C******

            CALL CALGEN

C******
C         CALCULATE ENERGY CONSUMPTION FOR THE BOILER/STEAM
C            /COGENERATION COMPONENT.
C******

            CALL CALSTOT

C******
C         CALCULATE TOTAL ENERGY CONSUMPTION FOR THE
C            INDUSTRY.
C******

            CALL INDTOTAL

C******
C         CALCULATE NATIONAL TOTAL ENERGY CONSUMPTION FOR THE
C            INDUSTRY.
C******

            IF(IR.EQ.4) THEN

              CALL NATTOTAL

C******
C         FILL IN VALUES FOR NEMS REPORT WRITER VARIABLES.
C******

              CALL CONTAB

            ENDIF

C******
C       IF IT IS PAST 1990, DO NECESSARY MODEL CALCULATIONS.
C******

          ELSE

C******
C     IF YEAR IS PAST 1990, READ BINARY RESTART FILES TO
C     ESTABLISH LAG VALUES, AND TO INITIATE VARIABLES.
C******

C******
C           ESTABLISH FIRST THE UNIT NUMBERS.
C******

            INDREG=IR

            CALL RDBIN
           if (inddir.eq.7.or.inddir.eq.8.or.inddir.eq.9.or. ! primary
     1         inddir.eq.12.or.inddir.eq.13) then
              prcx(1,ir)=prcx(23,ir)
              prcxyr(1,ir,iyr-1989)=prcxyr(23,ir,iyr-1989)
            elseif(inddir.eq.14) then ! metal based durables
              prcx(1,ir)=prcx(24,ir)
              prcxyr(1,ir,iyr-1989)=prcxyr(24,ir,iyr-1989)
            else
              prcx(1,ir)=prcx(25,ir)
              prcxyr(1,ir,iyr-1989)=prcxyr(25,ir,iyr-1989)
            endif
            IF(IWDBG.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1            WRITE(IUNIT1,8021) INDDIR
            IF(IWDBG.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1            WRITE(IUNIT1,8022) INDREG

            CALL MODCAL

          ENDIF

C******
C  CALCULATE INDUSTRY TOTALS.
C******

          CALL WRQTY

C******
C  WRITE INFORMATION TO BE SAVED TO THE RESTART FILES.
C******
          INDREG=IR
          CALL WRBIN

C******
C  CALL THE SUMMARY TABLE ROUTINE ON THE LAST ITERATION
C  FOR THE YEARS 1990, 2000, 2010.  THIS IS FOR REPORTING
C  IN THE DEBUG FILE.
C******

          IF(INDREG.EQ.4) THEN
            IF(IWRSUM.EQ.1) THEN
              IF((IYR.EQ.1990.OR.IYR.EQ.2000.OR.IYR.EQ.2010)
     1               .AND.(LSTITER.EQ.1)) CALL SUMTAB
            ENDIF
          ENDIF

        ENDDO

   45 CONTINUE
      IF(IYR.EQ.IBYR.AND.FSTITER.EQ.1.AND.PRTDBGI.GE.1) THEN
        DO IR=1,4
          DO ID=1,NUMIND
            WRITE(IUNIT2) B1ICUR(ID,IR)
          ENDDO
          DO IP=1,NUMPROC
            WRITE(IUNIT2) B1PCUR(IP,IR)
          ENDDO
        ENDDO
      ENDIF
      IF(IYR.EQ.IEYR.AND.LSTITER.EQ.1.AND.PRTDBGI.GE.1) THEN
        DO IR=1,4
          DO ID=1,NUMIND
            WRITE(IUNIT3) B2ICUR(ID,IR)
          ENDDO
          DO IP=1,NUMPROC
            WRITE(IUNIT3) B2PCUR(IP,IR)
          ENDDO
        ENDDO
      ENDIF

C******
C  CALCULATE NECESSARY COGENERATION VARIABLES FOR NEMS.
C******

      CALL INDCGN

C******
C  CLOSE PRODUCTION AND ENERGY FILE, IF FIRST YEAR.
C******

      IF(IYR.EQ.IBYR) THEN
        FNAME=NFILE(1)
        NEW=.FALSE.
        IUNIT4=FILE_MGR('C',FNAME,NEW)
      ENDIF

  801 FORMAT(1X,'DEBUG TEST FILE, YEAR = ',I4)
  991 FORMAT(3X,'MAIN ROUTINE')
 8021 FORMAT(' INDUSTRY= ',I4)
 8022 FORMAT(' REGION  = ',I4)

      RETURN
      END
C******
C  FOR THE MODEL DEVELOPER'S REPORT, THIS ROUTINE WILL ADJUST
C  PRICES FOR DISTILLATE, RESIDUAL OIL, COAL, NATURAL GAS
C  AND ELECTRICITY BY A FACTOR SPECIFIED IN THE RUNTIME FILE
C  THIS IS DONE FOR THE INDUSTRIAL SENSITIVITY RUNS.
C******
      SUBROUTINE PRICE
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDMACRO)

      INTEGER IR,JYR,ID,IF
      REAL DPRCX(30,11),E90PRCX(8),E91PRCX(8)
      REAL DCONX(30,11)

       DO IR=1,4
          PRCX(1,IR)=ELEC*PRCX(1,IR)
          PRCX(3,IR)=FGAS*PRCX(3,IR)
          PRCX(4,IR)=INTGAS*PRCX(4,IR)
          PRCX(7,IR)=COAL*PRCX(7,IR)
          PRCX(10,IR)=RESID*PRCX(10,IR)
          PRCX(11,IR)=DIST*PRCX(11,IR)
          PRCX(12,IR)=LPG*PRCX(12,IR)
       ENDDO

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE READS THE CONTROL FILE INDRUN.
C******
      SUBROUTINE RCNTL
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDTLOG)
      INCLUDE(INDBENCH)

      INTEGER I,J,K
      CHARACTER*80 COMMENT
C******
C  VARIABLES FOR FILE MANAGER ROUTINE.
C******
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW
C******

      INTEGER IUNIT9,IUNIT10,INDINT,INDRG,BOILMAX
      INTEGER*4 IOS
      REAL COEFF(25)
      CHARACTER*15 INDN

C******
C  OPEN THE CONTROL FILE INDRUN.
C******

      FNAME='INDRUN'
      NEW=.FALSE.
      IUNIT5=FILE_MGR('O',FNAME,NEW)
      READ(IUNIT5,801)
      READ(IUNIT5,803) ISUBTR   ! SUBROUTINE TRACE OPTION
      READ(IUNIT5,803) I        ! BEGINNING YEAR--OBSOLETE
      READ(IUNIT5,803) J        ! ENDING YEAR--OBSOLETE
      READ(IUNIT5,803) INDMAX   ! MAX NUMBER OF INDUSTRIES
      READ(IUNIT5,805) NFILE(1) ! PRODUCTION AND ENERGY DATA FILENAME--OBSOLETE
      READ(IUNIT5,803) IWDBG    ! DEBUG SWITCH
      READ(IUNIT5,805) NFILE(3) ! DEBUG FILE NAMENAME--OBSOLETE
      READ(IUNIT5,803) IWRSUM   ! OPTION TO WRITE SUMMARY TABLES
      READ(IUNIT5,805) NFILE(4) ! MACRO INPUTS FILENAME--OBSOLETE
      READ(IUNIT5,805) NFILE(5) ! PRICE INPUTS FILENAME--OBSOLETE
      READ(IUNIT5,803) ISEDS    ! OPTION FOR SEDS BENCHMARKING
      READ(IUNIT5,803) IPRICE   ! OPTION FOR PRICE SENSITIVITIES
        READ(IUNIT5,807) ELEC    !   ELEC PRICE sensitivity factor
        READ(IUNIT5,807) FGAS    !   firm gas price sensitivity factor
        READ(IUNIT5,807) INTGAS  !   interruptible gas price sensitivity
        READ(IUNIT5,807) COAL    !   coal
        READ(IUNIT5,807) RESID   !   resid
        READ(IUNIT5,807) DIST    !   distillate
        READ(IUNIT5,807) LPG     !   liquid petro gas

      READ(IUNIT5,803) ITPC      ! OPTION FOR TPC SENSTIVITIES
        READ(IUNIT5,807) TPC1
        READ(IUNIT5,807) TPC2

      READ(IUNIT5,803)FRZTECH  ! OPTION FOR FROZEN TECH CASE
      READ(IUNIT5,803)HITECH   ! OPTION FOR RAPID TECH CASE

      READ(IUNIT5,803)IRETIRE  ! OPTION FOR RETIREMENT RATE SENSITIVITIES
      READ(IUNIT5,807)RETRATE  ! RETIREMENT RATE MULTIPLIER

      READ(IUNIT5,803)MAXIND   ! MAX NUMBER OF INDUSTRIES WITH TRANSLOG COEFFICIENTS
      READ(IUNIT5,803)MAXCOEF  ! MAX NUMBER OF COEFFICIENTS PER INDUSTRY

      READ(IUNIT5,'(a)',END=99) COMMENT
      READ(IUNIT5,*,end=99,err=99) PRICEPA ! OPTION for logit fuel sharing in Process Assembly
      comment=' '
      do while(index(COMMENT,'CCAP').eq.0)
        READ(IUNIT5,'(a)',END=99) COMMENT
      ENDDO
      READ(IUNIT5,*,end=99,err=99)  CCAPOPT             ! Option to use CCAP Demand offsets
      READ(IUNIT5,'(a)',END=99) COMMENT                 ! skip line
      READ(IUNIT5,*,END=99,ERR=99) (CCAPFOS(j),j=1,3)   ! CCAP Fossil Demand offsets
      READ(IUNIT5,'(a)',END=99) COMMENT                 ! skip line
      READ(IUNIT5,*,END=99,ERR=99) (CCAPKWH(j),j=1,3)   ! CCAP ELECTRICITY BKWH Demand offsets
C convert from bkwh to end-use trils
      do j=1,3
        ccapkwh(j)=ccapkwh(j)*3.412                     ! 
      enddo
C******
C  CLOSE CONTROL FILE.
C******
99    IUNIT5=FILE_MGR('C',FNAME,NEW)

C  IF TRANSLOG OPTION, READ ECONOMETRIC COEFFICIENTS

         FNAME='ITRNLOG'
         IUNIT9=FILE_MGR('O',FNAME,NEW)
         DO J = 1,MAXIND
           READ(IUNIT9,*,IOSTAT=IOS)INDINT,(COEFF(I),I=1,MAXCOEF)
           IF(INDINT.EQ.13) INDINT=8
           IF(INDINT.EQ.15) INDINT=9
           IF(INDINT.EQ.24) INDINT=10
           IF(INDINT.EQ.25) INDINT=11
           IF(INDINT.EQ.27) INDINT=12
           IF(INDINT.EQ.28) INDINT=13
           IF(INDINT.EQ.34) INDINT=14
           IF(INDINT.EQ.35) INDINT=15
           DO K = 1,MAXCOEF
             TLCOEF(INDINT,K) = COEFF(K)
           ENDDO
         ENDDO
      IUNIT9=FILE_MGR('C',FNAME,NEW)

C******
C  READ PARAMETERS FROM HOMOTHETIC TRANSLOG FCN. FOR ESTIMATING
C  BOILER SHARE ELASTICITIES FOR INDUSTRIES 20,26,28,33,OTHER
C******
       FNAME='ITLBSHR'
       IUNIT10=FILE_MGR('O',FNAME,NEW)
       READ(IUNIT10,900)
       READ(IUNIT10,900)
       BOILMAX = 0.0     
       BOILMAX = MAXIND*4.0
       DO I = 1,BOILMAX
         READ(IUNIT10,*,IOSTAT=IOS)INDINT,INDRG,(COEFF(J),J=1,4)
           IF(INDINT.EQ.13) INDINT=8
           IF(INDINT.EQ.15) INDINT=9
           IF(INDINT.EQ.24) INDINT=10
           IF(INDINT.EQ.25) INDINT=11
           IF(INDINT.EQ.27) INDINT=12
           IF(INDINT.EQ.28) INDINT=13
           IF(INDINT.EQ.34) INDINT=14
           IF(INDINT.EQ.35) INDINT=15
         DO K = 1,4
           TLBSHR(INDINT,INDRG,K)=COEFF(K)
         ENDDO
       ENDDO
      IUNIT10=FILE_MGR('C',FNAME,NEW)

  801 FORMAT(1X)
  803 FORMAT(/,I4)
  805 FORMAT(/,A18)
  807 FORMAT(/,3X,F4.2)
  900 FORMAT(1X)
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE FILLS IN THE VALUE OF THE MODEL VARIABLES.
C  VARIABLES INCLUDE EMPLOYMENT AND VALUE OF OUTPUT.
C******



      SUBROUTINE REXOG
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDMACRO)
      INTEGER ISECT,IS,IR,IX,IY,ID

C******
C  WRITE SUBROUTINE TRACE, IF ON.
C******

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C******
C  FOR EACH INDUSTRY, FILL IN VALUE OF OUTPUT.
C******

      DO 10 ISECT=1,15 
        PRODVX(ISECT,1)=OUTIND(ISECT,1)+OUTIND(ISECT,2)
        PRODVX(ISECT,2)=OUTIND(ISECT,3)+OUTIND(ISECT,4)
        PRODVX(ISECT,3)=OUTIND(ISECT,5)+OUTIND(ISECT,6)+
     1                    OUTIND(ISECT,7)
        PRODVX(ISECT,4)=OUTIND(ISECT,8)+OUTIND(ISECT,9)
        PRODVX(ISECT,5)=OUTIND(ISECT,11)
 10   CONTINUE

C******
C  FOR EACH INDUSTRY, FILL IN EMPLOYMENT.
C******

      DO IS=1,15
        DO IR=1,5
          EMPLX(IS,IR)=0.0
        ENDDO
      ENDDO

      DO IR=1,5
        IF(IR.EQ.1) THEN
          IX=1
          IY=2
        ENDIF
        IF(IR.EQ.2) THEN
          IX=3
          IY=4
        ENDIF
        IF(IR.EQ.3) THEN
          IX=5
          IY=7
        ENDIF
        IF(IR.EQ.4) THEN
          IX=8
          IY=9
        ENDIF
        IF(IR.EQ.5) THEN
          IX=11
          IY=11
        ENDIF

        DO ID=IX,IY
          EMPLX(7,IR)=EMPLX(7,IR)+EMPIND(3,ID)         !FOOD
          EMPLX(8,IR)=EMPLX(8,IR)+EMPIND(9,ID)        !PAPER
          EMPLX(9,IR)=EMPLX(9,IR)+EMPIND(11,ID)*.635  !BULK CHEM
          EMPLX(10,IR)=EMPLX(10,IR)+EMPIND(15,ID)*.272  !GLASS
          EMPLX(11,IR)=EMPLX(11,IR)+EMPIND(15,ID)*.036  !CEMENT
          EMPLX(12,IR)=EMPLX(12,IR)+EMPIND(16,ID)*.555  !STEEL
          EMPLX(13,IR)=EMPLX(13,IR)+EMPIND(16,ID)*.123  !PR ALUM

          EMPLX(14,IR)=EMPLX(14,IR)+EMPIND(17,ID)       !METALS
     1 +                            EMPIND(18,ID)
     1 +                            EMPIND(19,ID)
     1 +                            EMPIND(20,ID)
     1 +                            EMPIND(21,ID)

c AGGREGATE EMPLOYMENT FOR OTHER NON-INTENSIVE INDUSTRY
          EMPLX(15,IR)=EMPLX(15,IR)+EMPIND(4,ID)         !OTHER NON-INT MFG
     1  +                         EMPIND(5,ID)
     1  +                         EMPIND(6,ID)
     1  +                         EMPIND(7,ID)
     1  +                         EMPIND(8,ID)
     1  +                         EMPIND(10,ID)
     1  +                         EMPIND(11,ID)*.365
     1  +                         EMPIND(12,ID)*.635
c    1  +                         EMPIND(12,ID)*.365
     1  +                         EMPIND(14,ID)
     1  +                         EMPIND(13,ID)
     1  +                         EMPIND(15,ID)*.693
     1  +                         EMPIND(16,ID)*.322
     1  +                         EMPIND(22,ID)

        ENDDO
      ENDDO

C******
C  ADJUST UNITS FROM NEMS (MILLION) TO WHAT WE NEED (THOUSAND)
C******

      DO IR=1,5
        DO ISECT=1,15
          EMPLX(ISECT,IR)=EMPLX(ISECT,IR)*1000.0
        ENDDO
      ENDDO

C******
C  FORMAT STATEMENTS
C******

  991 FORMAT(3X,'REXOG')

      RETURN
      END
C ************************************************************************** 
      REAL FUNCTION SumCDIV(DivArray,CensusReg)
      IMPLICIT NONE
C Sums the values from a census division array belonging to a given census region
C The first argument is an array of Census 9 division values.  It can be called with a
c subscripted multi-dimensional array as long as the first dimension is the Census detail 
c  and it is passed with a 1 as the first subscript.  For example, all of these would
c  be valid calls:
c     R2 = SumCDIV( X9, 2)               ! to get region 2 total of one-dimension array X9(9)
c     R2 = SumCDIV( QELIN(1,CURIYR), 2)  ! to get region 2 total of QELIN(11,29)
c     R3 = SumCDIV( CGOGQ(1,IY,ING1,IOWN), ICR ) to get region 3 total of CCOGQ(11,...) where
c                                                 the first dimension is the census region 
c
      INTEGER NCENSREG,NCENSDIV,MDivPerReg
      PARAMETER(NCENSREG=4,NCENSDIV=9,MDivPerReg=3)

      REAL DivArray(NCENSDIV)   ! Array Passed as argument--first dimension must be census region
      INTEGER CensusReg

      INTEGER             NDivPerReg(NCENSREG)/2,  2,  3,  2/

C                                             R1   R2  R3  R4
      INTEGER CDivByReg(NCENSREG,MDivPerReg)/  1,  3,  5,  8,    ! the Census Division #s in the 4 Regions
     1                                         2,  4,  6,  9,
     1                                         0,  0,  7,  0/

      INTEGER I,ICD
      REAL SUM
      SUM=0.
      DO I=1,NdivPerReg(CensusReg)
        ICD=CDivByReg(CensusReg,I)
        SUM=SUM + DivArray(ICD)
      ENDDO
      SumCDIV=SUM
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  WEXOG IMPLEMENTS BENCHMARKING AND ASSIGNS THE VARIABLES
C   THAT GO BACK TO THE NEMS SYSTEM.
C  THIS INCLUDES ANY SHARING TO CENSUS DIVISIONS AS NECESSARY.
C******
      SUBROUTINE WEXOG
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(APQ)
      INCLUDE(COGEN)
      INCLUDE(INDREP)
      INCLUDE(QCENSUS)
      INCLUDE(INDOUT)
      INCLUDE(INDCTRL)
      INCLUDE(INDCON)
      INCLUDE(INDMACRO)
      INCLUDE(INDCOGEN)
      INCLUDE(INDBENCH)
      INCLUDE(INDEBLK)
      INCLUDE(MACOUT)
      INCLUDE(EUSPRC)

C******
      INTEGER STEOBM,IMULTBM,RTOVALUE
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW

C******
C  DECLARE INTERNAL VARIABLES.
C******


      REAL HYDRO(11),GEO(7),SOLAR(7),WIND(7),BIOMASS(7)
      REAL CCAPEL(11), CCAPCL(11)  ! Climate Change Action Plan Effect for ELEC and COAL 
      REAL CCAPNG(11)    ! Climate Change Action Plan Effect for Natural Gas
      REAL DELTFOS,DELTKWH,deltng,deltcl
      REAL splitfos      ! assumed gas share of the fossil total
      PARAMETER(splitfos=0.85)

      INTEGER IP,JYR,IPP,NUM(9)
      INTEGER ICD,IF,ICR,IRF,IY,IR,YR,ID,IT,ITT,IREC,IFF,IYLAG,I
      REAL RENOUT(11)   ! $ Output for Lumber&Paper--used to share Renewables to census divisions
      REAL TOTRENW      ! = RENOUT(11)
      REAL NONTRAD(4,10)  ! nontraditional cogen by 4 regions, 10 fuels categories--from emm/cogen/
      REAL NUGSIND(6,9,3) ! Holds IPP or EWGCON history data for 1990-1995, census, 3 fuels
      REAL IFUEL(3)       ! Temp variable to read EWGCON
      REAL GROWFOS,GROWKWH ! CCAP growth rate for interpolating between 2000 and 2010
      INTEGER NGYRS  ! number of years for CCAP interpolation
      INTEGER IYEAR,IDIV,IOS,IOSTAT,J
      INTEGER DOONCE(MNUMYR)/MNUMYR*0/   ! variable to make sure some things are just done once
      INTEGER IUNIT25
      SAVE DOONCE

      INTEGER NSEDSFL,NCENSREG,NCENSDIV,NINDYFL,MDivPerReg
      PARAMETER(NSEDSFL=15,NCENSREG=4,NCENSDIV=9,MDivPerReg=3,
     1       NINDYFL=22)
      INTEGER NDivPerReg(NCENSREG)/2,2,3,2/
      REAL SEDS4(NSEDSFL,NCENSREG)               ! SEDS Quantities by 4 Census Regions for min(CURIYR,MSEDYR)
      REAL SEDS9(NSEDSFL,NCENSDIV)               ! SEDS Quantities by 9 Census Regions for min(CURIYR,MSEDYR)
      REAL SEDSHR(NSEDSFL,NCENSREG,MDivPerReg)   ! SEDS Division shares of Census region fuel consump
      REAL SEDSBF(NSEDSFL,NCENSREG)              ! SEDS Benchmark Factors at 15 fuels by 4 Census Regions
      REAL STEO(15,MSEDYR+1:MSEDYR+4)            ! Holds US STEO Quantities
      REAL STEOBF(NSEDSFL)                       ! STEO Benchmark factors for 15 fuels
      REAL STEOHIST(NSEDSFL)                     ! 1996 STEO History Benchmark Factors
      REAL STEOHISTlag(NSEDSFL)                  ! lagged STEO History Benchmark Factors
c     REAL BMAIN(NSEDSFL,NCENSREG)      ! Unbenchmarked model results 15-fuel level
      REAL BENCH(NSEDSFL,NCENSREG)      ! Seds-Benchmarked model results by 4 Census REGIONS
      REAL OTHIND4                      ! Consumption Increment from Benchmarking @ 4 Region Level
c     REAL OTHIND(NSEDSFL,NCENSDIV)     ! Consumption Increment from Benchmarking @ 9 Region Level
      REAL QUS,FADE,BF                  ! Used for STEO Benchmarking
      REAL FIRMSHR,SUMCDIV,SUM,DSHARE
      INTEGER IC,SF,ISEDYR,ISEDFL(19),F15,IOWN,ING3,ICL1,IGRD,
     1 IRL2,IYY
C                                             R1   R2  R3  R4
      INTEGER CDivByReg(NCENSREG,MDivPerReg)/  1,  3,  5,  8,    ! the Census Division #s in the 4 Regions
     1                                         2,  4,  6,  9,
     1                                         0,  0,  7,  0/

      INTEGER ICRCODE(11)/1,1,2,2,3,3,3,4,4,4,5/   ! Census region for each of 9 Census Divisions

C  Mapping of STEO fuel categories to 15-Fuel level.  For aggregating STEOQ(19..) into STEO(15..)
C  There are 19 Fuel categories in STEO file.  One is not used:
c                    14 (NG lease&plant).  hydro 19 (hydro) is
c                    used directlyated separately 
c  The 19 Fuel categories are mapped to 15 fuel categories consistent
c  with SEDS benchmarking as follows:
c 
c                   15-Fuel    19-Fuel  
C                   Index       Index
C                   =======    =======
      DATA    ISEDFL/ 7,     !    1      DISTILLATE(1)          
     &                6,     !    2      RESIDUAL(2)            
     &                8,     !    3      LPG(3)                 
     &                9,     !    4      MOGAS(4)               
     &               13,     !    5      PET FEED(5)            
     &               12,     !    6      ASPHALT(6)             
     &               14,     !    7      KEROSENE(7)            
     &               15,     !    8      LUBRICANTS(8)          
     &               11,     !    9      PETROL COKE(9)         
     &               10,     !   10      STILL GAS(10)          
     &               15,     !   11      WAXES(11)              
     &               15,     !   12      OTHER PET(12)          
     &                2,     !   13      NATURAL GAS(13)        
     &                0,     !   14      LEASE AND PLANT(14)    
     &                3,     !   15      STEAM COAL(15)          
     &                4,     !   16      MET COAL(16)           
     &                5,     !   17      NET COKE IMPORTS(17)   
     &                1,     !   18      ELECTRICITY(18)      
     &                0     /!   19      HYDRO(19)              
C******
C  HYDRO, KERO FROM SEDS. BIOMASS,SOLAR,WIND,GEO ARE FROM AER95
C  BIOMASS IS ALLOCATED BY PAPER AND LUMBER OUTPUT
C  SOLAR, WIND, GEOTHERMAL ALL GO TO DIVISION 9
C******
      DATA HYDRO/13.1,2.4,4.0,1.8,8.5,0.2,0.0,0.2,2.3,0.0,0.0/
      DATA SOLAR/7,8,8,9,8,8,9/
      DATA WIND/23,27,30,31,36,33,36/
      DATA GEO/153,168,179,204,212,207,231/
      DATA BIOMASS/1562,1528,1593,1625,1673,1698,1784/


C******
C  INITIALIZE VARIOUS INTERNAL VARIABLES.
C******

      JYR=IYR-1989
      IY=IYR-1989
      IYLAG=IY-1
      ITT=0
      IFF=0
      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)
C READ VALUES FROM NUGS FILE AND SUBTRACT 90-93  VALUES
C FROM SEDS VALUES
      IF(CURIYR.LE.MSEDYR.AND.FSTITER.EQ.1) THEN
        FNAME='EWGCON'
        IUNIT25=FILE_MGR('O',FNAME,NEW)
        READ(IUNIT25,900)
        DO I = 1,1888
          READ(IUNIT25,*,IOSTAT=IOS,END=888)IYEAR,IDIV,(IFUEL(J),J=1,3)
          IYEAR=IYEAR-89
          NUGSIND(IYEAR,IDIV,1) = IFUEL(1) ! coal
          NUGSIND(IYEAR,IDIV,2) = IFUEL(2) ! oil
          NUGSIND(IYEAR,IDIV,3) = IFUEL(3) ! nat gas
        ENDDO
888     CONTINUE
        IUNIT25=FILE_MGR('C',FNAME,NEW)
      ENDIF
900   FORMAT(1X)

C******
C  COPY NONTRADITIONAL COGEN CONSUMPTION FROM EMM/NERC REGION VARIABLE
C  AGGREGATE TO CENSUS REGION
C******
      DO IF=1,10
        NONTRAD(1,IF)=CGNTQ(7,IY,IF)+CGNTQ(3,IY,IF)+CGNTQ(6,IY,IF)
        NONTRAD(2,IF)=CGNTQ(1,IY,IF)+CGNTQ(4,IY,IF)+CGNTQ(5,IY,IF)
        NONTRAD(3,IF)=CGNTQ(8,IY,IF)+CGNTQ(9,IY,IF)+CGNTQ(10,IY,IF)
     1    +CGNTQ(2,IY,IF)
        NONTRAD(4,IF)=CGNTQ(12,IY,IF)+CGNTQ(11,IY,IF)+CGNTQ(13,IY,IF)
      ENDDO

C Fill SEDS vars--Done every year--the min(CURIYR,MSEDYR) returns the year index or the last
c SEDS year, whichever is smaller. 
      ISEDYR=MIN(CURIYR,MSEDYR)
      DO ICD=1,9
        SEDS9( 1,ICD)=QSELIN(ICD,ISEDYR)
        SEDS9( 2,ICD)=QSNGIN(ICD,ISEDYR) - NUGSIND(ISEDYR,ICD,3)
        SEDS9( 3,ICD)=QSCLIN(ICD,ISEDYR) - NUGSIND(ISEDYR,ICD,1) 

        SEDS9( 4,ICD)=QSMCIN(ICD,ISEDYR)
        DSHARE=QSMCIN(ICD,ISEDYR)/QSMCIN(11,ISEDYR)
        SEDS9( 5,ICD)=DSHARE*QSCIIN(11,ISEDYR)   ! SEDS Only Has National Coke Imports--Share to division using met coal    
        SEDS9( 6,ICD)=QSRSIN(ICD,ISEDYR)   ! - NUGSIND(ISEDYR,ICD,2) 
        SEDS9( 7,ICD)=QSDSIN(ICD,ISEDYR)
        SEDS9( 8,ICD)=QSLGIN(ICD,ISEDYR)
        SEDS9( 9,ICD)=QSMGIN(ICD,ISEDYR)
        SEDS9(10,ICD)=QSSGIN(ICD,ISEDYR)
        SEDS9(11,ICD)=QSPCIN(ICD,ISEDYR)
        SEDS9(12,ICD)=QSASIN(ICD,ISEDYR)
        SEDS9(13,ICD)=QSPFIN(ICD,ISEDYR)
        SEDS9(14,ICD)=QSKSIN(ICD,ISEDYR)
        SEDS9(15,ICD)=QSOTIN(ICD,ISEDYR)
      ENDDO

C  Aggregate SEDS from 9 Divsions to 4 Regions
      DO F15=1,NSEDSFL
        DO ICR=1,NCENSREG
          SEDS4(F15,ICR)=0.
          DO I=1,NDivPerReg(ICR)
             ICD=CDivByReg(ICR,I)
             SEDS4(F15,ICR)=SEDS4(F15,ICR)+SEDS9(F15,ICD)
          ENDDO

c Calculate Census Region to Division shares with SEDS

          DO I=1,NDivPerReg(ICR)
            ICD=CDivByReg(ICR,I)
            IF(SEDS4(F15,ICR).gt.0) THEN
              SEDSHR(F15,ICR,I)=SEDS9(F15,ICD)/SEDS4(F15,ICR)
            ELSE
              SEDSHR(F15,ICR,I)=1./FLOAT(NDivPerReg(ICR))  ! in case seds 0 and bmain > 0, use = shares
            ENDIF
          ENDDO
        ENDDO
      ENDDO
C Aggregate STEO history and forecast from 19 fuels (and SEDS-Based Census detail)
c to the 15-Fuel level.  
      DO F15=1,15
        DO IYEAR=1,4
          STEO(F15,MSEDYR+IYEAR)=0.
        ENDDO
      ENDDO         
      DO SF=1,19
        F15=ISEDFL(SF)
        IF(F15.NE.0) THEN
          DO IYEAR=1,4
            IYY=MSEDYR+IYEAR
            STEO(F15,IYY)=STEO(F15,IYY)+STEOQ(IYEAR,SF)
          ENDDO
        ENDIF
      ENDDO
c
c======================================================================================
c aggregate from 22 fuel level to 15 fuel level, and add Incremental and Nontraditional Cogen Fuel
      ICD=1
      ICL1=1
      ING3=3
      IRL2=2
      IOWN=1
      IGRD=2
      IY=CURIYR
      DO ICR=1,NCENSREG
        BMAIN(1,ICR)=TQMAIN(1,ICR) + SumCDIV( QELRF(ICD,IY), ICR)    ! Purchased electricity
        BMAIN(2,ICR)=TQMAIN(3,ICR) +                                 ! Natural Gas (non L&Pl-#6)
     1               TQMAIN(4,ICR) +
     1               TQMAIN(5,ICR) +
     1               SumCDIV(  CGOGQ(ICD,IY,ING3,IOWN), ICR ) +      ! + cogen
     1               SumCDIV(  CGOGQ(ICD,IY,ING3,IGRD), ICR ) + 
     1               SumCDIV(  QNGRF(ICD,IY),           ICR ) +
     1               NONTRAD(ICR,ING3)                               ! add nontraditional cogen

        BMAIN(3,ICR)=TQMAIN(7,ICR) +                                  ! steam coal
     1               SumCDIV(  CGOGQ(ICD,IY,ICL1,IOWN), ICR ) +
     1               SumCDIV(  CGOGQ(ICD,IY,ICL1,IGRD), ICR ) + 
     1               SumCDIV(  QCLRF(ICD,IY),           ICR ) +
     1               NONTRAD(ICR,ICL1)                                ! add nontraditional cogen

        BMAIN(4,ICR)=TQMAIN(8,ICR)                                ! METALLURGICAL COAL
        BMAIN(5,ICR)=TQMAIN(9,ICR)                                ! NET COAL COKE IMPORTS
        BMAIN(6,ICR)=TQMAIN(10,ICR) +                             ! Residual Fuel
     1               SumCDIV(  CGOGQ(ICD,IY,IRL2,IOWN), ICR ) +
     1               SumCDIV(  CGOGQ(ICD,IY,IRL2,IGRD), ICR ) + 
     1               SumCDIV(  QRLRF(ICD,IY),           ICR ) +
     1               NONTRAD(ICR,IRL2)                            ! add nontraditional cogen

        BMAIN(7,ICR)=TQMAIN(11,ICR)                               ! Distillate Oil
        BMAIN(8,ICR)=TQMAIN(12,ICR) +                             ! Liquid Petroleum Gases  (your basic tanes: propane and butane)
     1               TQMAIN(13,ICR) +
     1               SumCDIV(  QLGRF(ICD,IY), ICR ) 

        BMAIN(9,ICR)=TQMAIN(14,ICR)                               ! MOTOR GASOLINE
        BMAIN(10,ICR)=TQMAIN(15,ICR) +                            ! STILL GAS
     1                SumCDIV(  QSGRF(ICD,IY), ICR ) 

        BMAIN(11,ICR)=TQMAIN(16,ICR)  +                            ! PETROLEUM COKE
     1                SumCDIV(  QPCRF(ICD,IY), ICR ) 

        BMAIN(12,ICR)=TQMAIN(17,ICR)                              ! ASPHALT AND ROAD OIL
        BMAIN(13,ICR)=TQMAIN(19,ICR)                              !PETROCHEMICAL FEEDSTOCKS
C       BMAIN(14,ICR)=TQMAIN(20,ICR)                              ! KEROSENE-not filled by model
        BMAIN(14,ICR)=SumCDIV(QSKSIN(ICD,ISEDYR),ICR)             ! KEROSENE--use SEDS & hold constant

C OTHER PETROLEUM

        BMAIN(15,ICR)=TQMAIN(18,ICR) + 
     1                TQMAIN(21,ICR) +
     1                TQMAIN(22,ICR) + 
     1                SumCDIV(  QOTRF(ICD,IY), ICR ) 

      ENDDO

c
C  Compute SEDS benchmark factors at 15 fuel level

c  Check runtime option to turn multiplicative SEDS benchmarking off.
c  The default is on.  If off, then do additive (or absolute delta) SEDS benchmarking
c  
      IMULTBM=RTOVALUE('IMULTBM ',1)  

      IF(CURIYR.LE.MSEDYR) THEN
        DO F15=1,NSEDSFL
          DO ICR=1,NCENSREG
            IF(ISEDS.EQ.1) THEN
              IF(BMAIN(F15,ICR).NE. 0.0 ) THEN             ! If model shows consumption...
                IF(SEDS4(F15,ICR).NE.0) THEN                  !   and so does SEDS
                  SEDSBF(F15,ICR)=SEDS4(F15,ICR)/BMAIN(F15,ICR)     !  SEDS rules
                  if(imultbm.eq.0)
     1              sedsbf(f15,icr)=seds4(f15,icr)-bmain(f15,icr)  ! additive benchmarking
                ELSE                                          !   but SEDS doesn't
                  SEDSBF(F15,ICR)=1.                          !        INDy rules 
                  if(imultbm.eq.0)
     1              sedsbf(f15,icr)=0.
                ENDIF
              ELSE                                        !  but if the model says "no way",
                IF(SEDS4(F15,ICR).NE.0.0) THEN            !  and SEDS says "way" go with SEDS:
                  BMAIN(F15,ICR)=1.0                      !     Give the model a btu.
                  SEDSBF(F15,ICR)=SEDS4(F15,ICR)          !     Set the benchmark factor to yield SEDS 
                  if(imultbm.eq.0)
     1             SEDSBF(F15,ICR)=SEDS4(F15,ICR) 
                ELSE
                  SEDSBF(F15,ICR)=0.                      !  then it really must be zero.
                ENDIF
              ENDIF
              IF(F15.EQ.5) THEN                 ! net COKE IMPORTS GO NEGATIVE WHEN COKE OVENS 
                SEDSBF(F15,ICR)=1.              ! SUPPLY MORE THAN DEMANDED (eg.region 4 when OH retired),
                BMAIN(F15,ICR)=SEDS4(F15,ICR)   ! so set model results to SEDS (this is history, mind you)
                if(imultbm.eq.0)
     1          SEDSBF(F15,ICR)=0.
              ENDIF
                 
            ELSE                         
              SEDSBF(F15,ICR)=1.0               ! if no benchmarking, factor is 1.0
              if(imultbm.eq.0)
     1        SEDSBF(F15,ICR)=0.
            ENDIF
          ENDDO
        ENDDO
      ENDIF
c      Apply Benchmark factors at the 15 fuel/4 region level

      DO F15=1,NSEDSFL
        DO ICR=1,NCENSREG
          BENCH(F15,ICR)  = BMAIN(F15,ICR) * SEDSBF(F15,ICR)
          if(imultbm.eq.0)
     1      BENCH(F15,ICR) = BMAIN(F15,ICR) + SEDSBF(F15,ICR)
        ENDDO
      ENDDO
      
      STEOBM=RTOVALUE('STEOBM  ',0)

c   Compute STEO bench mark factors at national level.  
c   First STEO year is actual or History.  Subsequent years
c   are forecast and are used only if STEOBM switch is set.

      DO F15=1,NSEDSFL
       IF(CURIYR.LE.(MSEDYR+2)) THEN
          STEOHIST(F15)=1.
       ENDIF
       IF(CURIYR.GE.(MSEDYR+1).AND.CURIYR.LE.(MSEDYR+4)) then   ! 1995 to 1998 inclusive
         QUS=0.
         DO ICR=1,NCENSREG
           QUS=QUS+BENCH(F15,ICR)                               ! US Total of SEDS-Benchmarked Re
         ENDDO
         IF(QUS.NE.0) THEN
           STEOBF(F15)=STEO(F15,CURIYR)/QUS                     !  
         ELSE
           STEOBF(F15)=1.0
         ENDIF
         IF(CURIYR.EQ.MSEDYR+1)then !.OR.
c    1      CURIYR.EQ.MSEDYR+2)THEN ! Year after Last SEDS Year is History
           STEOHIST(F15)=STEOBF(F15)
           steohistlag(f15)=steohist(f15)   ! the value for msedyr+1
         ENDIF
         IF(CURIYR.EQ.MSEDYR+2)then !.OR.
           STEOHIST(F15)=(STEOBF(F15)+steohistlag(f15))/2. ! average the two years
         ENDIF
         IF(STEOBM.NE.1) THEN
           STEOBF(F15)=STEOHIST(F15)
         ENDIF
       ENDIF
     
C    Assign a ratio to fade out the effect of STEO benchmarking over three
C    years.  

       FADE=0.0                              ! 
       IF(CURIYR.GE.(MSEDYR+2).AND.                   ! No Fade (FADE=1.) in
     1   CURIYR.LE.(MSEDYR+4)) FADE=1.0              ! STEO Years 1996-1998
       IF(CURIYR.EQ.(MSEDYR+5)) FADE=0.9              ! In 1999
       IF(CURIYR.EQ.(MSEDYR+6)) FADE=0.8              !    2000
       IF(CURIYR.EQ.(MSEDYR+7)) FADE=0.6              !    2001
       IF(CURIYR.EQ.(MSEDYR+8)) FADE=0.4              !    2002
       IF(CURIYR.EQ.(MSEDYR+9)) FADE=0.2              !    2003
       IF(STEOBM.NE.1)          FADE=0.0              ! If STEO BM switch not set, zero it


       BF=STEOHIST(F15) + FADE * (STEOBF(F15)-STEOHIST(F15))
c if additive benchmarking, fade steo all the way
c back to one.  this will gradually return benchmarking back to
c the last seds year rather than the steo-history year.
       IF(IMULTBM.eq.0) then
         BF= 1. + FADE * (STEOBF(F15)- 1.0)

       ENDIF
       if(iseds.eq.0) BF = 1.0   !  if Benchmarking switch off, turn steo benchmarking off, too.
c 
C Apply US-Level History/STEO Benchmark Factor to Census Region Quantity. 
C Save Total amount benchmarked in the OTHer INDustry variable and disaggregate
C to the 9 Census divisions.  Also compute total Benchmark factor for industrial report writer 
c indgrp
       DO ICR=1,NCENSREG
          BENCH(F15,ICR) = BF * BENCH(F15,ICR)       ! Apply STEO Benchmark Factor
 
          OTHIND4= BENCH(F15,ICR) - BMAIN(F15,ICR)   ! Total Seds+Steo Benchmark 
          DO I=1,NDivPerReg(ICR)
            ICD=CDivByReg(ICR,I)
            OTHIND(F15,ICD)=OTHIND4*SEDSHR(F15,ICR,I)
            BENCHFAC(F15,ICD)=1.
            IF(BMAIN(F15,ICR).NE.0.0) 
     &        BENCHFAC(F15,ICD)=BENCH(F15,ICR)/BMAIN(F15,ICR)
          ENDDO
       ENDDO
                  
      END DO   ! End of DO F15 loop

C******
C  SINCE MOST RENEWABLES FROM THE PAPER AND LUMBER INDUSTRIES,
C  THE SHARES DEPEND ON THE TOTAL VALUE OF OUTPUT FOR THESE
C  INDUSTRIES.
C******
      DO ICD=1,11            
        RENOUT(ICD)=(mc_mfgo(icd,7,jyr) +         ! paper
     1               mc_mfgo(icd,5,jyr))/1000     ! lumber
        DSRENW(ICD)=0.
      ENDDO
      TOTRENW=RENOUT(11)
C For each Census Region, compute the shares for each of its divisions
      DO ICR=1,NCENSREG
        SUM=SumCDIV(  RENOUT(1), ICR)    ! Sum of the divisions for this region
        IF (SUM.GT.0.0) THEN
          DO I=1,NDivPerReg(ICR)          ! for each division in this region
            ICD=CDivByReg(ICR,I)
            DSRENW(ICD)=RENOUT(ICD)/SUM
          ENDDO
        ENDIF
      ENDDO
      DSRENW(11)=1.0

C******
C  CALCULATE CONSUMPTION BY DIVISION BY FUEL.
C******
      YR=MIN(CURIYR,MSEDYR+2)
      DO ICD=1,9
        BIOFUELS(ICD)=BIOMASS(YR)*RENOUT(ICD)/TOTRENW
        DQRENW(1,ICD)=QSHOIN(ICD,ISEDYR)   ! Hydro from SEDS--Held constant thereafter
        IF(CURIYR.GE.MSEDYR) THEN        ! For 1994+, get Hydro from data statement--SEDS 94 renew not ready
          DQRENW(1,ICD)=HYDRO(ICD)     
        ENDIF
C   Share Renewables From Census Region to Census Division based on Paper/Lumber Shares
        ICR=ICRCODE(ICD)
        DO IF=2,8
          DQRENW(IF,ICD)=TQRENW(IF,ICR)*DSRENW(ICD)
        ENDDO
CCADD COGEN CONSUMPTION OF BIOMASS TO PRIMARY BIOMASS CONSUMPTION
c*** these are now being added into the correct spot at the industry level ***
c*** in CALSTOT so do NOT do it here                                       ***
c       DQRENW(2,ICD) = DQRENW(2,ICD) + 
c    1      .5*(DIVFUEL(ICD,4,1)+DIVFUEL(ICD,4,2))
c       DQRENW(3,ICD) = DQRENW(3,ICD) + 
c    1      .5*(DIVFUEL(ICD,4,1)+DIVFUEL(ICD,4,2))

CCADD COGEN MSW CONSUMPTION TO PRIMARY MSW CONSUMPTION
        DQRENW(8,ICD)=DQRENW(8,ICD)+(DIVFUEL(ICD,6,1)+
     1     DIVFUEL(ICD,6,2))
      ENDDO
C******
C IF in history, compute benchmark factor for BIOMASS.  
C  Apply BENCHMARKING FACTOR to WOOD and PULPING PAPER. 

C******
       IF(ISEDS.EQ.1) THEN
         IF(CURIYR.LE.MSEDYR+2) THEN
           DO ICD=1,9
             SUM=DQRENW(2,ICD)+DQRENW(3,ICD)   ! Total includes COGEN added in above
             DO IRF=2,3
               BENCHFAC(IRF+14,ICD)=1.
               IF(SUM.GT.0.0)BENCHFAC(IRF+14,ICD)=BIOFUELS(ICD)/SUM
             ENDDO 
           ENDDO
         ENDIF
         DO ICD = 1,9
           DO IRF = 2,3
             DQRENW(IRF,ICD)=BENCHFAC(IRF+14,ICD)*DQRENW(IRF,ICD)
           ENDDO
         ENDDO
       ENDIF
C******
C  SAVE BENCHMARK FACTORS TO IBENCH FILE.
C******

      CALL IWBEN(JYR)

c  Assign Values for CCAP Offset.  The assumed effects are given as the
c  fossil fuel savings (CCAPFOS) and electricity savings (CCAPKWH) for 2000 and 2010.  
c  1) For minimum CO2 effect, assume all fossil savings  are in natural gas use.
c  2) For years between 2000 and 2010, and 2010 and 2020, 
c     interpolate using constant growth rate
c  3) Share to Census regions based on SEDS shares       

      DO ICD=1,11
        CCAPCL(ICD)=0.
        CCAPEL(ICD)=0.
        CCAPNG(ICD)=0.
      ENDDO
      IF(CCAPOPT.EQ.1) then
       IF(JYR.GE.11.and.JYR.LE.21) then
        ngyrs=min(10,jyr-11)
        DELTng  = splitfos * (CCAPFOS(2) - CCAPFOS(1))
        DELTcl  = (1. - splitfos) * (CCAPFOS(2) - CCAPFOS(1))
        DELTKWH =  CCAPKWH(2) - CCAPKWH(1)
        CCAPNG(11) = CCAPFOS(1) * splitfos
     1             + 0.1*DELTng*ngyrs ! assume all firm gas
        CCAPCL(11) = CCAPFOS(1) * (1. - splitfos)
     1             + 0.1*DELTcl*ngyrs
        CCAPEL(11) = CCAPKWH(1) + 0.1*DELTKWH*ngyrs
       elseif(JYR.GT.21) THEN
        ngyrs=min(10,jyr-21)
        DELTng  = splitfos * (CCAPFOS(3) - CCAPFOS(2))
        DELTcl  = (1. - splitfos) * (CCAPFOS(3) - CCAPFOS(2))
        DELTKWH =  CCAPKWH(3) - CCAPKWH(2)
        CCAPNG(11) = CCAPFOS(2) * splitfos
     1             + 0.1*DELTng*ngyrs ! assume all firm gas
        CCAPCL(11) = CCAPFOS(2) * (1. - splitfos)
     1             + 0.1*DELTcl*ngyrs
        CCAPEL(11) = CCAPKWH(2) + 0.1*DELTKWH*ngyrs
       ENDIF
       if(jyr.ge.11) then
C share to census regions         
        DO ICD=1,9
          CCAPCL(ICD)=CCAPCL(11)*
     1            (QSCLIN(ICD,MSEDYR)/QSCLIN(11,MSEDYR))   
          CCAPEL(ICD)=CCAPEL(11)*
     1            (QSELIN(ICD,MSEDYR)/QSELIN(11,MSEDYR))   
          CCAPNG(ICD)=CCAPNG(11)*
     1            (QSNGIN(ICD,MSEDYR)/QSNGIN(11,MSEDYR))   
        ENDDO
       endif
      ENDIF   
C******
C  PUT THE CONSUMPTION FROM THE MAIN AND RENEWABLE QUANTITY
C  ARRAYS INTO THE NEMS VARIABLES, BY CENSUS DIVISION.
C  Note: US totals for Q-Arrays done in MAIN
C******
      IY=CURIYR                                                       ! reset to be on safe side 
      DO ICR=1,NCENSREG
         DO I=1,NDivPerReg(ICR)
            ICD=CDivByReg(ICR,I)
C Main Fuels
            QEPIN(ICD,IY)=0.0                                         ! Peak Elec    --not available
            QENIN(ICD,IY)=0.0                                         ! Nonpeak Elec --not available
            QELIN(ICD,IY)=BENCH(1,ICR)*SEDSHR(1,ICR,I)                ! Electricity
            IF(JYR.GE.11.and.CCAPOPT.eq.1) THEN
              QELIN(ICD,IY) = QELIN(ICD,IY) - CCAPEL(ICD)             ! Subtract CCAP Effect
            ENDIF
c separate the total electric into the three categories ***     
c primary,shift,miscellaneous                           ***
c the shares are at the census region level             ***

         qelinp(1,iy)=qelin(1,iy)*xelinshr(1,1)
         qelinp(2,iy)=qelin(2,iy)*xelinshr(1,1)
         qelinp(3,iy)=qelin(3,iy)*xelinshr(1,2)
         qelinp(4,iy)=qelin(4,iy)*xelinshr(1,2)
         qelinp(5,iy)=qelin(5,iy)*xelinshr(1,2)
         qelinp(6,iy)=qelin(6,iy)*xelinshr(1,3)
         qelinp(7,iy)=qelin(7,iy)*xelinshr(1,3)
         qelinp(8,iy)=qelin(8,iy)*xelinshr(1,4)
         qelinp(9,iy)=qelin(9,iy)*xelinshr(1,4)
         qelins(1,iy)=qelin(1,iy)*xelinshr(2,1)
         qelins(2,iy)=qelin(2,iy)*xelinshr(2,1)
         qelins(3,iy)=qelin(3,iy)*xelinshr(2,2)
         qelins(4,iy)=qelin(4,iy)*xelinshr(2,2)
         qelins(5,iy)=qelin(5,iy)*xelinshr(2,2)
         qelins(6,iy)=qelin(6,iy)*xelinshr(2,3)
         qelins(7,iy)=qelin(7,iy)*xelinshr(2,3)
         qelins(8,iy)=qelin(8,iy)*xelinshr(2,4)
         qelins(9,iy)=qelin(9,iy)*xelinshr(2,4)
         qelinm(1,iy)=qelin(1,iy)*xelinshr(3,1)
         qelinm(2,iy)=qelin(2,iy)*xelinshr(3,1)
         qelinm(3,iy)=qelin(3,iy)*xelinshr(3,2)
         qelinm(4,iy)=qelin(4,iy)*xelinshr(3,2)
         qelinm(5,iy)=qelin(5,iy)*xelinshr(3,2)
         qelinm(6,iy)=qelin(6,iy)*xelinshr(3,3)
         qelinm(7,iy)=qelin(7,iy)*xelinshr(3,3)
         qelinm(8,iy)=qelin(8,iy)*xelinshr(3,4)
         qelinm(9,iy)=qelin(9,iy)*xelinshr(3,4)

C    NATURAL GAS (NON LEASE AND PLANT).  Share total gas between firm and interruptible
   
            FIRMSHR=0.
            IF(BMAIN(2,ICR).GT.0.0) THEN
              FIRMSHR=(TQMAIN(3,ICR)+TQMAIN(5,ICR))/ BMAIN(2,ICR)     
            ENDIF
            QGFIN(ICD,IY)=BENCH(2,ICR)*SEDSHR(2,ICR,I)*FIRMSHR  ! firm  nat gas
            QGIIN(ICD,IY)=BENCH(2,ICR)*SEDSHR(2,ICR,I)*(1.-FIRMSHR) ! interruptible nat gas
            QNGIN(ICD,IY)=BENCH(2,ICR)*SEDSHR(2,ICR,I)           ! total  nat gas
c***    subtract ccap from firm and total natural gas is ccapot is on ***
            if(jyr.ge.11.and.ccapopt.eq.1) then
              QGFIN(ICD,IY) = QGFIN(ICD,IY) - ccapng(icd)
              QNGIN(ICD,IY) = QNGIN(ICD,IY) - ccapng(icd)
            endif
            BF=BENCHFAC(2,ICD)
            INQNGPF(ICD,IY)=BF*TQMAIN(5,ICR)*SEDSHR(2,ICR,I)     ! Benchmark FEEDSTOCK GAS

            QCLIN(ICD,IY)=BENCH(3,ICR) * SEDSHR(3,ICR,I)
            if(jyr.ge.11.and.ccapopt.eq.1) then
              QCLIN(ICD,IY) = QCLIN(ICD,IY) - CCAPCL(ICD)    ! Subtract CCAP Effect, 2001-on
            endif
            QMCIN(ICD,IY)=BENCH( 4,ICR) * SEDSHR( 4,ICR,I)            ! met coal
            QCIIN(ICD,IY)=BENCH( 5,ICR) * SEDSHR( 5,ICR,I)            ! net coal coke import
            QRLIN(ICD,IY)=BENCH( 6,ICR) * SEDSHR( 6,ICR,I)            ! resid, low sulfur
            QRSIN(ICD,IY)=BENCH( 6,ICR) * SEDSHR( 6,ICR,I)            ! resid, total
            QDSIN(ICD,IY)=BENCH( 7,ICR) * SEDSHR( 7,ICR,I)            ! distillate
            QLGIN(ICD,IY)=BENCH( 8,ICR) * SEDSHR( 8,ICR,I)            ! liquid petrol gases
            QMGIN(ICD,IY)=BENCH( 9,ICR) * SEDSHR( 9,ICR,I)            ! motor gasoline
            QSGIN(ICD,IY)=BENCH(10,ICR) * SEDSHR(10,ICR,I)            ! still gas
            QPCIN(ICD,IY)=BENCH(11,ICR) * SEDSHR(11,ICR,I)            ! petroleum coke
            QASIN(ICD,IY)=BENCH(12,ICR) * SEDSHR(12,ICR,I)            ! asphalt

            QPFIN(ICD,IY)=BENCH(13,ICR) * SEDSHR(13,ICR,I)            ! petro feedstocks
            BF=BENCHFAC(8,ICD)
            INQLGPF(ICD,IY)=BF*TQMAIN(13,ICR)*SEDSHR(8,ICR,I)         ! LPG FEEDSTOCKS

            QKSIN(ICD,IY)=BENCH(14,ICR) * SEDSHR(14,ICR,I)            ! kerosene
            QOTIN(ICD,IY)=BENCH(15,ICR) * SEDSHR(15,ICR,I)            ! other petroleum

C  Renewable fuels
            QHOIN(ICD,IY)=DQRENW(1,ICD)
            QBMIN(ICD,IY)=DQRENW(2,ICD) + DQRENW(3,ICD)
            QGEIN(ICD,IY)=DQRENW(4,ICD)
            QSTIN(ICD,IY)=DQRENW(5,ICD)
            QPVIN(ICD,IY)=DQRENW(6,ICD)
            QWIIN(ICD,IY)=DQRENW(7,ICD)
            QMSIN(ICD,IY)=DQRENW(8,ICD)
            QTRIN(ICD,IY)=QHOIN(ICD,IY)+QGEIN(ICD,IY)+QBMIN(ICD,IY)+
     &                    QMSIN(ICD,IY)+QSTIN(ICD,IY)+QPVIN(ICD,IY)+
     &                    QWIIN(ICD,IY)
         ENDDO
      ENDDO

C*
C  Total feedstock gas and lpg over divisions
C*

      INQNGPF(11,IY)=0.
      INQLGPF(11,IY)=0.
      DO ICD = 1,9
        INQNGPF(11,IY) = INQNGPF(11,IY) + INQNGPF(ICD,IY)
        INQLGPF(11,IY)= INQLGPF(11,IY) + INQLGPF(ICD,IY)
      ENDDO
c ***
c   get a us total for the 3 electricity groups   
c ***
      qelinp(11,IY)=0.
      qelins(11,IY)=0.
      qelinm(11,IY)=0.
      DO ICD = 1,9
         qelinp(11,IY)= qelinp(11,iy) + qelinp(icd,iy)
         qelins(11,IY)= qelins(11,iy) + qelins(icd,iy)
         qelinm(11,IY)= qelinm(11,iy) + qelinm(icd,iy)
      ENDDO

C******
C  COGENERATION VARIABLES ARE PASSED TO NEMS.
C  FOR AEO95 and AEO96:
C  DO NOT ADD THE VARIABLES FROM OTHER MODELS
C  FIRST ZERO OUT WHATEVER IS ALREADY THERE
C******

        DO ID=1,11  ! divisions
          DO IF=1,10  ! nems fuels
            DO IT=1,2
              CGINDCAP(ID,IY,IF,IT,1)=0.0          !CAPACITY
              CGINDCAP(ID,IY,IF,IT,2)=0.0          !UNPLANNED
              CGINDGEN(ID,IY,IF,IT)=0.0            !GENERATION
              CGINDQ(ID,IY,IF,IT)=0.0              !FUEL CONS
            ENDDO
          ENDDO
        ENDDO
        DO 150 ID=1,11
        DO 150 IF=1,3  ! the first 3 internal fuels match nems fuels   coal, oil, gas
          DO IT=1,2    ! own use, grid sales
            CGINDCAP(ID,IY,IF,IT,1)=CAPGW(ID,IF,IT,1)
            CGINDGEN(ID,IY,IF,IT)=GENGWH(ID,IF,IT)
            CGINDQ(ID,IY,IF,IT)=DIVFUEL(ID,IF,IT)
          ENDDO
150    CONTINUE

       CGINDQ(11,IY,7,1) = 0.0
       CGINDQ(11,IY,7,2) = 0.0

       DO ID=1,9
        DO IT=1,2
         CGINDCAP(ID,IY,7,IT,1)=CAPGW(ID,4,IT,1) ! biomass
         CGINDCAP(ID,IY,10,IT,1)=CAPGW(ID,5,IT,1)! other
         CGINDCAP(ID,IY,6,IT,1)=CAPGW(ID,6,IT,1) ! msw

         CGINDGEN(ID,IY,7,IT)=GENGWH(ID,4,IT)
         CGINDGEN(ID,IY,10,IT)=GENGWH(ID,5,IT)
         CGINDGEN(ID,IY,6,IT)=GENGWH(ID,6,IT)

         CGINDQ(ID,IY,7,IT)=DIVFUEL(ID,4,IT)
         CGINDQ(ID,IY,10,IT)=DIVFUEL(ID,5,IT)
         CGINDQ(ID,IY,6,IT)=DIVFUEL(ID,6,IT)

         CGINDGEN(11,IY,6,IT) = CGINDGEN(11,IY,6,IT) +
     1     CGINDGEN(ID,IY,6,IT)

         CGINDGEN(11,IY,7,IT) = CGINDGEN(11,IY,7,IT) +
     1     CGINDGEN(ID,IY,7,IT)

         CGINDGEN(11,IY,10,IT) = CGINDGEN(11,IY,10,IT) +
     1     CGINDGEN(ID,IY,10,IT)

        CGINDCAP(11,IY,6,IT,1) = CGINDCAP(11,IY,6,IT,1) +
     1     CGINDCAP(ID,IY,6,IT,1)

        CGINDCAP(11,IY,7,IT,1) = CGINDCAP(11,IY,7,IT,1) +
     1     CGINDCAP(ID,IY,7,IT,1)

         CGINDCAP(11,IY,10,IT,1) = CGINDCAP(11,IY,10,IT,1) +
     1     CGINDCAP(ID,IY,10,IT,1)

         CGINDQ(11,IY,6,IT)=CGINDQ(11,IY,6,IT)+
     1                             CGINDQ(ID,IY,6,IT)

         CGINDQ(11,IY,7,IT)=CGINDQ(11,IY,7,IT)+
     1                             CGINDQ(ID,IY,7,IT)

         CGINDQ(11,IY,10,IT)=CGINDQ(11,IY,10,IT)+
     1                             CGINDQ(ID,IY,10,IT)
         ENDDO
       ENDDO

C******
C  REPORT TABLES VARIABLES ARE PASSED TO NEMS.
C******

C******
C     MANUFACTURING HEAT AND POWER
C******

      MANHP(1,IY)=TMANHP(1)+QELRF(11,IY) ! electricity
      MANHP(2,IY)=TMANHP(2)+QNGRF(11,IY) ! nat gas
      MANHP(3,IY)=TMANHP(3)+QCLRF(11,IY) ! steam coal
      MANHP(4,IY)=TMANHP(4)              ! met coal
      MANHP(5,IY)=TMANHP(5)              ! coke imports
      MANHP(6,IY)=TMANHP(6)+QRLRF(11,IY) ! residual
      MANHP(7,IY)=TMANHP(7)+QDSRF(11,IY) ! disillate
      MANHP(8,IY)=TMANHP(8)+QLGRF(11,IY) ! lpg h&p
      MANHP(9,IY)=TMANHP(9)+QPCRF(11,IY) ! petroleum coke
      MANHP(10,IY)=TMANHP(10)+QSGRF(11,IY) ! still gas
      MANHP(11,IY)=TMANHP(11)+QOTRF(11,IY) ! oth pet, kerosene
      MANHP(12,IY)=TMANHP(12)+QBMRF(11,IY) ! biomass

C******
C     NONMANUFACTURING HEAT AND POWER
C******

      NONHP(1,IY)=TNONHP(1) ! electricity
      NONHP(2,IY)=TNONHP(2)+CGOGQ(11,IY,3,1)+CGOGQ(11,IY,3,2)!nat gas
      NONHP(3,IY)=TNONHP(3)+CGOGQ(11,IY,1,1)+CGOGQ(11,IY,1,2)!steam coal
      NONHP(4,IY)=TNONHP(4)+CGOGQ(11,IY,2,1)+CGOGQ(11,IY,2,2)!residual
      NONHP(5,IY)=TNONHP(5) ! distillate
      NONHP(6,IY)=TNONHP(6) ! lpg h&p
      NONHP(7,IY)=TNONHP(7) ! mogas
      NONHP(8,IY)=TNONHP(8) ! other petroleum

C******
C     MISCELLANEOUS FUELS AND FEEDSTOCKS.
C******

      DO IF=1,6
        MISCFD(IF,IY)=TMISCFD(IF)
      ENDDO

C******
C     TABLE FOR MFG, NON-MFG, AND FEEDSTOCKS.
C******

       CALL SECTAB
       CALL MFGTAB

      DO IF=1,12
        CHEMCON(IF,IY)=TCHEMCON(IF)     ! Chemical
        FOODCON(IF,IY)=TFOODCON(IF)     ! FOOD INDUSTRY CONSUMPTION.
        GLASSCON(IF,IY)=TGLASSCON(IF)   ! Glass
        PAPERCON(IF,IY)=TPAPERCON(IF)   ! Paper
        CEMENTCON(IF,IY)=TCEMENTCON(IF) ! Cement
        STEELCON(IF,IY)=TSTEELCON(IF)   ! Steel
        ALUMCON(IF,IY)=TALUMCON(IF)     ! Aluminum
        REFCON(IF,IY)=TREFCON(IF)     ! Refining
      ENDDO

C******
C     FIRST, OPEN A THIRD BINARY FILE SINBIN3
C******

      FNAME='SINBIN3'
      IF(IYR.EQ.IBYR.AND.FSTITER.EQ.1.AND.PRTDBGI.GE.1) THEN
        NEW=.TRUE.
        IUNIT7=FILE_MGR('O',FNAME,NEW)
      ENDIF

C******
C     SECOND, WRITE ALL THE VARIABLES.
C******

      IREC=IY
      IF(LSTITER.EQ.1.AND.DOONCE(IY).EQ.0.AND.PRTDBGI.GE.1) THEN
        DOONCE(IY)=1
        WRITE(IUNIT7)
     1  OUTIND,                                  !OUTPUT
     2  EMPIND,                                  !EMPLOYMENT
     3  ENPRC,                                   !ENERGY PRICES
C  REFINING CONSUMPTION
     1  (QEPRF(ID,IY),ID=1,11),
     2  (QENRF(ID,IY),ID=1,11),
     3  (QELRF(ID,IY),ID=1,11),
     1  (QGFRF(ID,IY),ID=1,11),
     2  (QGIRF(ID,IY),ID=1,11),
     3  (QNGRF(ID,IY),ID=1,11),
     1  (QCLRF(ID,IY),ID=1,11),
     2  (QRLRF(ID,IY),ID=1,11),
     3  (QDSRF(ID,IY),ID=1,11),
     1  (QLGRF(ID,IY),ID=1,11),
     2  (QSGRF(ID,IY),ID=1,11),
     3  (QPCRF(ID,IY),ID=1,11),
     1  (QOTRF(ID,IY),ID=1,11),
C  NATURAL GAS LEASE AND PLANT CONSUMPTION
     2  (QLPIN(ID,IY),ID=1,11),
C  COGENERATION VARIABLES FROM REFINING AND OIL AND GAS.
     1  (((CGREGEN(ID,IY,IF,IT),ID=1,11),IF=1,4),IT=1,2),
     1  (((CGOGGEN(ID,IY,IF,IT),ID=1,11),IF=1,4),IT=1,2),
     1((((CGRECAP(ID,IY,IF,IT,IP),ID=1,11),IF=1,4),IT=1,2),IP=1,2),
     1((((CGOGCAP(ID,IY,IF,IT,IP),ID=1,11),IF=1,4),IT=1,2),IP=1,2),
     1  (((CGREQ(ID,IY,IF,IT),ID=1,11),IF=1,4),IT=1,2),
     1  (((CGOGQ(ID,IY,IF,IT),ID=1,11),IF=1,4),IT=1,2)
      ENDIF
C******
  991 FORMAT(3X,'WEXOG')

      RETURN
      END
C ******************************************************************************
      SUBROUTINE IWBEN(JYR)
      IMPLICIT NONE
C******
C     IWBEN WRITES THE SEDS AND STEO FACTORS.
C     THE AVERAGE OR FADE OUT IS DONE ON THE RETURN
C******
      INCLUDE(INDCTRL)
      INCLUDE(INDBENCH)
      INCLUDE(INDCON)

      INTEGER JYR,IREC


      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW

C******
C     OPEN BENCHMARK FILE.
C******

      FNAME='IBENCH'
      IF(IYR.EQ.IBYR.AND.FSTITER.EQ.1) THEN
        NEW=.TRUE.
        IUNIT8=FILE_MGR('O',FNAME,NEW)
      ENDIF

C******
C     SAVE BENCHMARK FACTORS TO IBENCH.
C******

      IREC=JYR
      WRITE(IUNIT8,REC=IREC)BENCHFAC,OTHIND

  991 FORMAT(3X,'IWBEN')

      RETURN
      END
C ******************************************************************************
      SUBROUTINE IRSTEO
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(INDCTRL)
      INCLUDE(INDMACRO)
      INCLUDE(INDBENCH)
      INTEGER IUNIT13,IYEAR,IC,SF
      CHARACTER*18 FNAME
      CHARACTER*70 FUEL 
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      LOGICAL NEW
C OPEN AND READ FILE CONTAINING STEO FOR 1995, 1996 AND 1997
C
      FNAME='INDSTEO'
      IUNIT13=FILE_MGR('O',FNAME,NEW)
      NEW=.FALSE.
      READ(IUNIT13,992)  ! SKIP THE FILE HEADER
      DO SF=1,19
        READ(IUNIT13,*) (STEOQ(IYEAR,SF),IYEAR=1,4)
      ENDDO
      IUNIT13=FILE_MGR('C',FNAME,NEW)
  992 FORMAT(A)

      RETURN
      END
      SUBROUTINE TLBENCH
      IMPLICIT NONE
C
C    BENCHMARK UEC ESTIMATED USING TRANSLOG FUNCTION
C    METHODOLOGY TO 1991 VALUES
C

      INCLUDE(INDCTRL)
      INCLUDE(INDTLOG)
      INCLUDE(INDPA)
      INTEGER I,IF,IS,IFX,IT

      DO IS = 1,MPASTP
       DO IF = 1,IFMAX(IS)
        IFX = IFLOC(IF,IS)
         IF(IFX.EQ.1.OR.IFX.EQ.3.OR.IFX.EQ.7.OR.IFX.EQ.10.OR
     1      .IFX.EQ.11.OR.IFX.EQ.12) THEN
           DO I = 1,3
            IF(ENPINT(I,IF,IS).GT.0.000001) THEN
              TLFAC(INDDIR,INDREG,I,IF,IS) =
     1                ENPINTLAG(I,IF,IS)/ENPINT(I,IF,IS)
            ENDIF

           ENDDO
          ENDIF
         ENDDO
       ENDDO

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE ZEROCHK
      IMPLICIT NONE
C
C     FOR EACH INSTANCE THAT ONE OF THE COST SHARES
C     BECOMES NONPOSITIVE, SET TO ZERO, AND REALLOCATE
C     AMONG THE REMAINING COST SHARES
C
      INCLUDE(INDPA)
      INCLUDE(INDTLOG)

      INTEGER I,J,K,IS,IF,IFL
      REAL SUM
      REAL COSTSHR(6)
C  RECALCULATE SHARES TO SUM TO ONE SINCE ONE OR MORE ARE LESS
C  THAN ONE
C  INITIALIZE COSTSHR VARIABLE

      DO I = 1,6
       COSTSHR(I) = 0.0
      ENDDO

      COSTSHR(1) = S1
      COSTSHR(2) = S2
      COSTSHR(3) = S3
      COSTSHR(4) = S4
      COSTSHR(5) = S5
      COSTSHR(6) = S6

      DO I = 1,6
        IF(COSTSHR(I).LT.0.0) THEN
          COSTSHR(I)=0.0
        ENDIF
      ENDDO

      SUM = 0.0

      DO J = 1,6
        SUM = SUM + COSTSHR(J)
      ENDDO

      DO K = 1,6
        COSTSHR(K) = COSTSHR(K)/SUM
      ENDDO

      S1 = COSTSHR(1)
      S2 = COSTSHR(2)
      S3 = COSTSHR(3)
      S4 = COSTSHR(4)
      S5 = COSTSHR(5)
      S6 = COSTSHR(6)

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE IBSBEN
      IMPLICIT NONE

C    CALCULATE BENCHMARK FACTORS FOR THE BOILER SHARES

      INCLUDE(INDCTRL)
      INCLUDE(INDBSC)

      INTEGER IF

C****
C     CALCULATE BENCHMARK FACTORS FOR BOILER FUEL SHARES
C     ENSURE THAT BASE YEAR BOILER  SHARES CARRY FORWARD
C****

        DO IF = 1,IFSMAX
           BSBENCHFAC(INDDIR,INDREG,IF) = BSSHRLAG(IF)/BSSHR(IF)
        ENDDO

       RETURN
       END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   IEDATA READS THE PRODUCTION AND MAIN ENERGY DATA FILE FOR
C     FOR EACH REGION OF EACH INDUSTRY IN THE INITIAL YEAR
C     DATA FILE: ENPROD
C     (REPLACES EXISTING PDATA AND EDATA)
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IEDATA
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INCLUDE(INDBLD)
      INCLUDE(INDBSC)
      INCLUDE(INDCOGEN)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)

C****
C  DECLARE INTERNAL VARIABLES.
C****
      INTEGER *4 IOS  ,I
      INTEGER NUMIND,IFLAG,NUMFMT,NLASTREG,IERR,ICOUNT,NUMREG,
     1    LINDDIR,INDEX,NUMEIIND,IHEADER,ISTEPDEF,ICOGEN,INEIELAS,
     2    IEISTEP,EIFLAG, NSTEP,IFUEL,IFL,IVINT,IR,NFUELS,IFPX,IEQ,
     3    ISTP,ICA,ICB,ILOOP,J
      REAL TOTSHR,BTEMP
      REAL TEMPVAR
C
      CHARACTER *200 ISTR
      CHARACTER *100 MSG(5)
C
C   DEFINE NUMBER OF INDUSTRIES, FORMATS, ENERGY INTENSIVE INDUSTRIES
C      AND REGIONS
C
      PARAMETER (NUMIND=15, NUMFMT=9, NUMEIIND=7, NUMREG=4)
      CHARACTER *8 INAME(NUMIND),IFORMT(NUMFMT),EIIND(NUMEIIND),
     1 ITAG,LINDNAME,LTAGNAME,INAMECK(NUMIND)
      INTEGER IREGCK(NUMREG)
C
C   USE DATA STATEMENTS TO DEFINE FILE FORMATS, INDUSTRIES, AND
C     ENERGY INTENSIVE INDUSTRIES.
C
      DATA IFORMT /'.HEADER ',
     2             '.STEPDEF',
     3             'BEU     ',
     4             'BSCBYP  ',
     5             'BSFUEL  ',
     6             'COGEN   ',
     7             'NEIELAS ',
     8             'STEPBYP ',
     9             'EISTEP'/
C
      DATA INAME /'01AGCROP', '02AGOTHR', '03COALMN', '04OILGAS',
     1'05METLMN', '06CONSTR', '07FOOD  ', '08PAPER ', '09B_CHEM', 
     2'10GLASS ','11CEMENT','12STEEL ', '13ALUMNM', '14METALS',
     3'15NON-IN'/
C
      DATA INAMECK/NUMIND*'XYZ     '/
      DATA IREGCK/NUMREG*0/
C
      DATA EIIND /'07FOOD  ', '08PAPER ', '09B_CHEM', '10GLASS ',
     1  '11CEMENT', '12STEEL ', '13ALUMNM'/
C
      DATA MSG/
     1 'HAS INVALID FIRST RECORD; MUST BE .HEADER.  SKIP RECORD.',
     2 'MAX ONE PER SUBSECTION; SKIP DUPLICATES',
     3 'HAS INVALID SECOND RECORD; MUST BE .STEPDEF.  SKIP RECORD.',
     4 'HAS INVALID FILE FORMAT.  SKIP RECORD.',
     5 'HAS INVALID REGION NUMBER.  SKIP RECORD.' /

C
C***
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

      CALL IZEROOUT(ITAG,NLASTREG,ISTP,NSTEP,IEQ,IFPX,NFUELS,
     1     IFUEL,LINDNAME,IHEADER,ISTEPDEF,ICOGEN,INEIELAS,IEISTEP)
C
      ICOUNT=1
C
      DO 10 ILOOP=1,5000
C
C   READ IN ONE DATA RECORD
C
      READ(IUNIT4,1,ERR=100,END=105,IOSTAT=IOS) INDNAME,INDREG,ITAG
     1 ,ISTR
1     FORMAT(A8,1X,I8,1X,A8,1X,A200)
C
C   CHECK FOR CORRECT INDUSTRY NAME.  IF NOT, WRITE A MESSAGE AND
C      SKIP TO NEXT RECORD
C
      CALL ICHECK(IFLAG,NUMIND,INAME,INDNAME,INDEX)
      IF (IFLAG.EQ.0) THEN
        IF(PRTDBGI.GE.2) WRITE(6,2) INDNAME
2       FORMAT(1X,'SUB_IEDATA:  INDUSTRY NAME=',A8,
     1            ' NOT RECOGNIZED, SKIP RECORD')
        GO TO 10
      ENDIF
C
C   CHECK FOR ENERGY INTENSIVE INDUSTRY.  IF SO, SET EIFLAG=1
C
      IF(ICOUNT.EQ.1) THEN
        CALL ICHECK(EIFLAG,NUMEIIND,EIIND,INDNAME,INDEX)
      ENDIF
C
C   FILE SUBSECTIONS MUST BEGIN WITH A .HEADER RECORD.  ONLY ONE
C     WILL BE READ PER SUBSECTION
C
      IF(ICOUNT.EQ.1.AND.ITAG.NE.IFORMT(1)) THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(1)
4       FORMAT(1X,'SUB_IEDATA:  ',A8,' REGION',I3,', ',A8,1X,A100)
        GO TO 10
      ELSEIF(ICOUNT.EQ.2.AND.ITAG.EQ.IFORMT(1))THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(2)
        GO TO 10
      ENDIF
C
C   THE SECOND RECORD OF A FILE SUBSECTION MUST BE .STEPDEF.
C     ENERGY INTENSIVE INDUSTRIES MAY HAVE MORE THAN ONE.
C
      IF(ICOUNT.EQ.2.AND.ITAG.NE.IFORMT(2)) THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(3)
        GO TO 10
      ENDIF
C
C   EACH FILE SUBSECTION MAY HAVE ONE VALID COGEN RECORD.  SUBSEQUENT
C     COGEN RECORDS ARE SKIPPED
C
      IF(ITAG.EQ.IFORMT(6).AND.ICOGEN.GT.0) THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(2)
        GO TO 10
      ENDIF
C
C   CHECK FOR VALID FILE FORMAT NAME.  IF NOT, WRITE A MESSAGE
C     AND SKIP TO NEXT RECORD
C
      CALL ICHECK(IFLAG,NUMFMT,IFORMT,ITAG,INDEX)
      IF(IFLAG.EQ.0) THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(4)
        GO TO 10
      ENDIF
C
C   IF REGION NUMBER OUT OF RANGE, WRITE A MESSAGE
C      AND SKIP TO NEXT RECORD
C
      IF(INDREG.LT.1.OR.INDREG.GT.NUMREG) THEN
        WRITE(6,4) INDNAME,INDREG,ITAG,MSG(5)
        GO TO 10
      ENDIF
C
C   WRITE FILE SUBSECTION DESCRIPTION TO PRINTER
C
      IF(ICOUNT.EQ.1) THEN
        IF(PRTDBGI.GE.2)WRITE(6,7) INDNAME, INDREG
7       FORMAT(1X,'SUB_IEDATA:  READING ENPROD INDUSTRY '
     1        ,A8,', REGION',I3)
      ENDIF
C
      IF(ICOUNT.GT.1)THEN
C
C   IF THIS IS A NEW INDUSTRY, CHECK IF ALL REGIONS WERE REPRESENTED
C     IN THE LAST INDUSTRY
C
        IF(INDNAME.NE.LINDNAME) THEN
          DO J=1,NUMREG
            IF(IREGCK(J).NE.J)THEN
              WRITE(6,11) LINDNAME,J
11            FORMAT(1X,'SUB_IEDATA WARNING: ',A8,' REGION'
     1              ,I3,' IS MISSING')
            ENDIF
            IREGCK(J)=0          ! AFTER CHECKING, ZERO OUT
          ENDDO
        ENDIF
C
C    IF THIS IS A NEW REGION OR INDUSTRY, BACKSPACE THE FILE,
C       MAKE SURE THE FILE SUBSECTION HAD THE CORRECT COMPONENTS,
C       MODIFY THE PRODUCTIONS FLOWS TO REFLECT IMPORTS
C       AND EXPORTS, CALCULATE PRODUCTION THROUGHPUT FOR EACH STEP,
C       AND RETURN TO CALLING ROUTINE.
C
        IF(INDREG.NE.NLASTREG.OR.INDNAME.NE.LINDNAME) THEN
          BACKSPACE(IUNIT4)
        INDREG = NLASTREG
        INDNAME = LINDNAME
C
          CALL IFINLCHECK(IFLAG,LINDNAME,NLASTREG,IHEADER,ISTEPDEF,
     1      MPASTP,ICOGEN,EIFLAG,INEIELAS,IEISTEP,IFMAX,INAMECK,
     2      INDDIR,NUMIND)
          IF(IFLAG.GT.0)RETURN
C
          CALL IFINLCALC

C
C
          RETURN
        ENDIF

      ENDIF
C
C   IF NO CHANGE IN INDUSTRY OR REGION, CALL THE APPROPRIATE READ
C     SUBROUTINE BASED ON THE VALUE OF THE FORMAT NAME
C
      IF(ITAG.EQ.IFORMT(1)) THEN
        CALL IRHEADER(ISTR,PRODVX,PRODX,INDREG,INDDIR,IDVAL,
     1       PHDRAT,CUMOUT88,STEMCUR,TEMPVAR,IERR,IOS)
        IF(IERR.NE.1) IHEADER=IHEADER+1
        IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) THEN
          IF(LSTITER.EQ.1) THEN
            WRITE(IUNIT1,8021) INDDIR
            WRITE(IUNIT1,8022) INDREG
          ENDIF
          WRITE(IUNIT1,992) IDVAL,PHDRAT
        ENDIF
C
      ELSEIF(ITAG.EQ.IFORMT(2)) THEN
        CALL IRSTEPDEF(ISTR,IERR,IOS,ISTP)
        IF(IERR.NE.2)ISTEPDEF=ISTEPDEF+1
C
      ELSEIF(ITAG.EQ.IFORMT(3)) THEN
        CALL IRBEU(ISTR,IOS,IERR,IFLAG)
        IF(IFLAG.EQ.0) GO TO 10              ! INVALID FUEL USE NAME
C                                              OR INVALID FUEL NUMBER
      ELSEIF(ITAG.EQ.IFORMT(4)) THEN
        CALL IRBSCBYP(ISTR,IOS,IERR)
C
      ELSEIF(ITAG.EQ.IFORMT(5)) THEN
        CALL IRBSFUEL(ISTR,IOS,IERR)
C
      ELSEIF(ITAG.EQ.IFORMT(6)) THEN
        CALL IRCOGEN(ISTR,IOS,IERR)
        IF(IERR.NE.6) ICOGEN=ICOGEN+1

C
      ELSEIF(ITAG.EQ.IFORMT(7)) THEN
        IF(EIFLAG.EQ.1) THEN
          WRITE(6,77)INDNAME,ITAG
77        FORMAT(1X,'SUB_IEDATA:  ',A8,' HAS NO '
     1          ,A8,' COMPONENT; SKIP RECORD')
          GO TO 10
        ENDIF
C
        MPASTP=1                     ! 1 STEP FOR NEI INDUSTRY
        INDSTEPNAME(1)='N/A'         ! STEP NAME IS N/A
        CALL IRNEIELAS(ISTR,IOS,IERR)
        IF(IERR.NE.7) INEIELAS=INEIELAS+1
C
      ELSEIF(ITAG.EQ.IFORMT(8)) THEN
        CALL IRSTEPBYP(ISTR,IOS,IERR,IFLAG)
        IF(IFLAG.EQ.0) GO TO 10      ! INVALID STEP NAME
C
      ELSE
        IF(EIFLAG.EQ.0) THEN
          WRITE(6,90) INDNAME,ITAG
90        FORMAT(1X,'SUB_IEDATA WARNING:  ',A8,' HAS NO '
     1             ,A8,' COMPONENT.  SKIP RECORD.')
          GO TO 10
        ENDIF
C
        CALL IRSTEPDAT(ISTR,IOS,IERR,IFLAG)
        IF(IFLAG.EQ.0) GO TO 10      ! INVALID STEP NAME
        IF(IERR.NE.9) IEISTEP=IEISTEP+1
C
      ENDIF
C
      IF(IERR.GT.0) GO TO 100          ! INDICATES A READ ERROR
C
C   STORE THE CURRENT REGION NUMBER, INCREMENT THE COUNT
C   OF VALID RECORDS IN THIS REGION AND STORE THE
C     INDUSTRY NAME, REGION NUMBER, AND TAG NAME
C
      IF(ICOUNT.EQ.1) THEN
        IREGCK(INDREG)=INDREG
      ENDIF
      ICOUNT=ICOUNT+1
      LINDNAME=INDNAME
      LINDDIR=INDDIR
      NLASTREG=INDREG
      LTAGNAME=ITAG
C
C
10    CONTINUE
C
      WRITE(6,99)
99    FORMAT(1X,'SUB_IEDATA ERROR:  LOOP INCREMENT EXCEEDED BEFORE '
     1      ,'EOF ENCOUNTERED.')
      RETURN
C
100   WRITE(6,101) IOS
101   FORMAT(1X,'SUB_IEDATA READ ERROR NUMBER ',I5)
      IF(IERR.GT.0) THEN
        WRITE(6,102) IFORMT(IERR)
102     FORMAT(1X,'SUB_IEDATA ERROR:  READING ENPROD FORMAT TYPE '
     1          ,A8)
      ENDIF
      RETURN
C
C   MODIFY PRODUCTION FLOWS FOR LAST REGION OF LAST INDUSTRY
C
105   CONTINUE
C
      CALL IFINLCHECK(IFLAG,LINDNAME,NLASTREG,IHEADER,ISTEPDEF,
     1  MPASTP,ICOGEN,EIFLAG,INEIELAS,IEISTEP,IFMAX,INAMECK,
     2  INDDIR,NUMIND)
      IF(IFLAG.GT.0)RETURN
      CALL IFINLCALC
C
C   CHECK IF ALL REGIONS WERE REPRESENTED IN THE LAST INDUSTRY
C
      DO J=1,NUMREG
        IF(IREGCK(J).NE.J)THEN
          WRITE(6,11) LINDNAME,J
        ENDIF
      ENDDO
C
C   CHECK IF ALL INDUSTRIES ARE REPRESENTED IN THIS RUN
C
      DO I=1,NUMIND
        IF(INAMECK(I).NE.INAME(I)) THEN
          WRITE(6,106) INAME(I),INAMECK(I)
106       FORMAT(1X,'SUB_IEDATA INDUSTRY ',A8,' NOT REPRESENTED. ('
     1          ,A8,')')
        ENDIF
      ENDDO
C
      IF(PRTDBGI.GE.2)WRITE(6,110)IOS
110   FORMAT(1X,'SUB_IEDATA:  ENPROD EOF ENCOUNTERED ',I5)
C
991   FORMAT(3X,'IEDATA')
8021  FORMAT(' INDUSTRY= ',I4)
8022  FORMAT(' REGION = ',I4)
992   FORMAT(3X,I2,F25.5)
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
C   SUBROUTINE ICHECK CHECKS IF THE NAME ICHAR IS AN ELEMENT OF THE
C     ARRAY ICHARAR WITH HAS NUMVAR ELEMENTS.
C     IF FOUND, CHECK RETURNS A VALUE IFLAG=1 AND THE INDEX NUMBER.
C     OTHERWISE CHECK RETURNS A VALUE IFLAG=0.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE ICHECK(IFLAG,NUMVAR,ICHARAR,ICHAR,INDEX)
      IMPLICIT NONE
      INTEGER IFLAG,NUMVAR,ILOOP,INDEX
      CHARACTER *8 ICHARAR(50),ICHAR
      IFLAG = 0
      ILOOP = 1
      DO WHILE(ILOOP.LE.NUMVAR.AND.IFLAG.EQ.0)
         IF(ICHAR.EQ.ICHARAR(ILOOP)) THEN
           IFLAG=1
           INDEX=ILOOP
         ENDIF
         ILOOP=ILOOP+1
      END DO
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRHEADER READS THE .HEADER RECORD, THE FIRST
C    RECORD ON FILE FOR EACH REGION OF EACH INDUSTRY.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRHEADER(ISTR,PRODVX,PRODX,INDREG,
     1 INDDIR,IDVAL,PHDRAT,CUMOUT88,STEMCUR,TEMPVAR,IERR,IOS)
      IMPLICIT NONE
      INCLUDE(INDBENCH)
      INTEGER INDDIR,IDVAL,IERR,INDREG
      INTEGER *4 IOS
      REAL PHDRAT,CUMOUT88,STEMCUR,PRODVX(15,5),PRODX(15,5),TEMPVAR
      CHARACTER *200 ISTR
      IERR=0
      READ(ISTR,*,ERR=100,IOSTAT=IOS)INDDIR,IDVAL,PHDRAT,CUMOUT88,
     1     STEMCUR
 
c     IF(INDDIR.EQ.13) INDDIR=8
c     IF(INDDIR.EQ.15) INDDIR=9
c     IF(INDDIR.EQ.24) INDDIR=10
c     IF(INDDIR.EQ.25) INDDIR=11
c     IF(INDDIR.EQ.27) INDDIR=12
c     IF(INDDIR.EQ.28) INDDIR=13
c     IF(INDDIR.EQ.34) INDDIR=14
c     IF(INDDIR.EQ.35) INDDIR=15
C****
C  CALCULATE THE PHYSICAL UNITS BASED ON THE VALUE OF IDVAL
C****
 
      IF(IDVAL.EQ.1) THEN
        TONOUT(INDDIR,INDREG)=PHDRAT            ! Save Base Year Tons
        PHDRAT=PHDRAT/PRODVX(INDDIR,INDREG)        !RATIO OF PHY TO DOLLAR VALUE
        PRODX(INDDIR,INDREG)=PHDRAT*PRODVX(INDDIR,INDREG)
      ENDIF
      IF(IDVAL.EQ.2) THEN
        PRODX(INDDIR,INDREG)=PRODVX(INDDIR,INDREG)
      ENDIF
C
      RETURN
100   IERR=1
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRSTEPDEF READS THE .STEPDEF RECORD,THE SECOND RECORD
C     ON FILE FOR EACH REGION OF EACH INDUSTRY.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRSTEPDEF(ISTR,IERR,IOS,ISTP)
      IMPLICIT NONE 
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
C
      REAL TEMP1,TEMP2,EPSILON
      INTEGER IERR,ISTP,ICA,ICB
      INTEGER *4 IOS
      CHARACTER *8 TNAME
      CHARACTER *200 ISTR,ISTR2
      DATA EPSILON /.00001/
C
      IERR=0
C
C   FIRST READ IS FORMATTED TO READ CHARACTER DATA
C
      READ(ISTR,1,ERR=100,IOSTAT=IOS) TNAME,ISTR2
1     FORMAT(A8,1X,A191)
C
C   SECOND READ IS UNFORMATTED
C
      READ(ISTR2,*,ERR=100,IOSTAT=IOS) ISTP,NTMAX(ISTP),
     1    (IPASTP(ISTP,ICA),ICA=1,5),(PRODFLOW(1,ISTP,ICB),ICB=1,5),
     2     PRODRETR(ISTP),(PRODFLOW(2,ISTP,ICB),ICB=1,5),TEMP1,TEMP2
C
C   COUNT THE PROCESS/ASSEMBLY STEPS
C
      MPASTP=MPASTP+1
      INDSTEPNAME(ISTP)=TNAME
C
C   FILL IN IMPORT AND EXPORT ARRAYS IF VALUES ARE NON-ZERO
C

      RETURN
100   IERR=2
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRBEU READS THE BUILDING ENERGY USE COMPONENT FOR
C     INDUSTRIES WITH THAT COMPONENT; INCLUDES BUILDING LIGHTING
C     AND HEATING, VENTILATING, AND AIR CONDITIONING.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRBEU(ISTR,IOS,IERR,IFLAG)
      IMPLICIT NONE
      INCLUDE(INDBLD)

      CHARACTER *200 ISTR,ISTR2
      CHARACTER *8 TNAME, NAMEAR(2)
      INTEGER *4 IOS
      INTEGER J,IERR,IFX,INDEX,IFLAG
      REAL TEMP(3)
      DATA NAMEAR/'LIGHT','HVAC'/
C
      IERR=0
C
C   FIRST READ IS FORMATTED TO READ CHARACTER DATA
C
      READ(ISTR,1,ERR=100,IOSTAT=IOS)TNAME,ISTR2
1     FORMAT(A8,1X,A191)
C
C   SECOND READ IS UNFORMATTED
C
      READ(ISTR2,*,ERR=100,IOSTAT=IOS) IFX,
     1 (TEMP(J),J=1,3)
C
C   1, 2, OR 3 ARE THE ONLY VALID FUEL NUMBERS IN THE BEU COMPONENT
C      CHECK FOR THESE NUMBERS
C
      IF(IFX.LT.1.OR.IFX.GT.3) THEN
        WRITE(6,2) IFX
2       FORMAT(1X,'SUB_IRBEU WARNING:  BEU HAS NO FUEL NUMBER',I3,
     1   ' MUST BE 1, 2, OR 3.  SKIP RECORD.')
        IFLAG=0
        RETURN
      ENDIF
C
C   CHECK FOR A VALID FUEL USE NAME AND FIND FUEL USE NUMBER
C
      CALL ICHECK(IFLAG,2,NAMEAR,TNAME,INDEX)
      IF(IFLAG.EQ.0) THEN                   ! INVALID FUEL USE
        WRITE(6,5) TNAME
5       FORMAT(1X,'SUB_IRBEU WARNING:  BEU HAS NO FUEL USE FOR ',
     1    A8,' SKIP RECORD')
        RETURN
      ENDIF
C
C  IF VALID FUEL USE TYPE, ASSIGN VALUES TO APPROPRIATE ARRAYS
C
      ENBINT(INDEX,IFX)=TEMP(1)
      BBCSC(INDEX,IFX) =TEMP(2)
      BBELAS(INDEX,IFX)=TEMP(3)
      RETURN
C
100   IERR=3
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C    SUBROUTINE IRBSCBYP READS BYPRODUCT FUEL INFORMATION FOR
C      INDUSTRIES HAVING A BOILER/STEAM COMPONENT WHICH USE
C      BYPRODUCT FUELS (GENERALLY PRODUCED IN THAT INDUSTRY'S
C      PROCESS/ASSEMBLY COMPONENT).
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRBSCBYP(ISTR,IOS,IERR)
      IMPLICIT NONE
      INCLUDE(INDBSC)
C
      CHARACTER *200 ISTR
      INTEGER *4 IOS
      INTEGER J,IERR,IDUM,IFX
      REAL TEMP(2)
C
      IERR=0
C
C   IDUM IS THE FUEL SEQUENCE NUMBER--NOT ACTUALLY USED
C
      READ(ISTR,*,ERR=100,IOSTAT=IOS) IDUM,IFX,
     1 (TEMP(J),J=1,2)
C
C   COUNT BYPRODUCT FUELS, AND STORE FUEL NUMBER AND OTHER VALUES
C     IN THE APPROPRIATE POSITION IN THE ARRAYS
C
      IFSBYP=IFSBYP+1
      IFSLOCBY(IFSBYP)=IFX
      BYSINT(IFSBYP)  =TEMP(1)
      BYBSCSC(IFSBYP) =TEMP(2)
C
      RETURN
C
100   IERR=4
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRBSFUEL READS FUEL INFORMATION FOR THOSE INDUSTRIES
C     WITH A BOILER/STEAM COMPONENT.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRBSFUEL(ISTR,IOS,IERR)
      IMPLICIT NONE
      INCLUDE(INDBSC)
C
      CHARACTER *200 ISTR
      INTEGER *4 IOS
      INTEGER J,IERR,IFX,IDUM
      REAL TEMP(6)
C
      IERR=0
C
C   IDUM IS THE SEQUENCE NUMBER--NOT ACTUALLY USED
C
      READ(ISTR,*,ERR=100,IOSTAT=IOS) IDUM,IFX,
     1 (TEMP(J),J=1,6)
C
C   COUNT THE BS FUELS AND STORE THE FUEL NUMBER AND OTHER VALUES
C     IN THE APPROPRIATE POSITION OF THE ARRAYS.
C
      IFSMAX=IFSMAX+1
      IFSLOC(IFSMAX)=IFX
      BSSHR(IFSMAX)   =TEMP(1)
      ENSINT(IFSMAX)  =TEMP(6)
C
      RETURN
C
100   IERR=5
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRCOGEN READS COGENERATION DATA FOR THOSE INDUSTRIES
C     WITH A COGENERATION COMPONENT.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRCOGEN(ISTR,IOS,IERR)
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INCLUDE(INDCOGEN)

      CHARACTER *200 ISTR
      INTEGER *4 IOS
      INTEGER IERR

       INTEGER IUNIT9,IUNIT10,IUNIT11,IUNIT12
       INTEGER IYEAR,ISIC,ICENSUS,INDSIC,IC,YR
       INTEGER I,J,K,L,M,N,IF,IP
       REAL CAPACITY,UTILRATE,HEATRATE,FUELSHR(7)
       REAL GEN,CONS 
       REAL GRDSHR,GRDSALE
       real dumvar
       real sum(11)
       CHARACTER*3 SOURCE
       CHARACTER*2 PM
       CHARACTER*10 FNAME
       INTEGER FILE_MGR
       EXTERNAL FILE_MGR
       LOGICAL NEW

C
      IERR=0
C
      READ(ISTR,*,ERR=100,IOSTAT=IOS)dumvar,GSTEAM,GEN90,dumvar,dumvar,
     1  dumvar, GENEQPSHR(1),GENEQPHTRT(1),GENEQPSTEFF(1),
     2           GENEQPSHR(2),GENEQPHTRT(2),GENEQPSTEFF(2),
     3           GENEQPSHR(3),GENEQPHTRT(3),GENEQPSTEFF(3),
     4           GENEQPSHR(4),GENEQPHTRT(4),GENEQPSTEFF(4)

C READ EI-867 DATA FOR GENERATION EXISTING AND PLANNED
C CAPACITY FILES
C FIRST INITIALIZE FUEL ARRAY

      IF(IYR.EQ.1990.AND.INDNUM.EQ.1.AND.INDREG.EQ.1) THEN
       IF(FSTITER.EQ.1) THEN
         DO J = 1,6 !fuels
           FUELSHR(J) = 0.0 !initialize fuel share array
         ENDDO

C*******
C OPEN AND READ FILE CONTAINING EXISTING CAPACITY NUMBERS FOR
C 1990 through 1995
C*******
        FNAME='EXSTCAP'
        IUNIT9=FILE_MGR('O',FNAME,NEW)
        READ(IUNIT9,900)
        READ(IUNIT9,900)
       DO I=1,1888                                      ! keep going until the end of file reached
        READ(IUNIT9,*,IOSTAT=IOS,END=888)IYEAR,ISIC,IC,PM,HEATRATE,
     1  CAPACITY,UTILRATE,GRDSALE,GRDSHR,(FUELSHR(J),J = 1,6)
        IF(ISIC.EQ.1) INDSIC= 1
        IF(ISIC.EQ.2.OR.ISIC.EQ.7.OR.ISIC.EQ.8.OR.ISIC.EQ.9) INDSIC=2
        IF(ISIC.EQ.11.OR.ISIC.EQ.12) INDSIC=3
        IF(ISIC.EQ.13) INDSIC=4
        IF(ISIC.EQ.10.OR.ISIC.EQ.14) INDSIC=5
        IF(ISIC.EQ.15.OR.ISIC.EQ.16.OR.ISIC.EQ.17) INDSIC=6
        IF(ISIC.EQ.20) INDSIC=7
        IF(ISIC.EQ.26.OR.ISIC.EQ.2621.OR.ISIC.EQ.2631) INDSIC=8
       IF(ISIC.EQ.28.OR.ISIC.EQ.2821.OR.ISIC.EQ.2869.OR.ISIC.EQ.2873
     1  .OR.ISIC.EQ.2819.)INDSIC=9
        IF(ISIC.EQ.3241) INDSIC=11
        IF(ISIC.EQ.3312) INDSIC=12
        IF(ISIC.EQ.3334) INDSIC=13
        IF(ISIC.EQ.34) INDSIC=14
        IF(ISIC.EQ.35) INDSIC=15
        IF(PM.EQ.'GT') THEN
          IP=2
        ELSE IF(PM.EQ.'IC') THEN
          IP=1
        ELSE IF(PM.EQ.'ST'.OR.PM.EQ.'SF') THEN
          IP=3
        ELSE IF(PM.EQ.'HY') THEN
          IP=4
        ELSE
          IF(PRTDBGI.GE.2)WRITE(6,*)'WRONG TYPE ',PM
        ENDIF
        YR = IYEAR - 89

C ASSIGN VALUES TO ARRAY OF EXISTING CAPACITY FOR COGEN
       IF(INDSIC.LE.15.AND.IC.LE.9) THEN
        IF(UTILRATE.GT.1.0) UTILRATE = 1.0
        CAP867(IC,YR,INDSIC,IP) = CAPACITY
        SICUTIL(IC,YR,INDSIC,IP) = UTILRATE
        IGRIDSHR(IC,YR,INDSIC) = GRDSHR
        RATE(IP) = HEATRATE
        SHARE(IP,IC,YR,INDSIC,1) = FUELSHR(2) ! Coal
        SHARE(IP,IC,YR,INDSIC,2) = FUELSHR(3) ! Petro
        SHARE(IP,IC,YR,INDSIC,3) = FUELSHR(1) ! Gas
        SHARE(IP,IC,YR,INDSIC,4) = FUELSHR(4) ! Wood 
        SHARE(IP,IC,YR,INDSIC,5) = FUELSHR(5) ! Other
        SHARE(IP,IC,YR,INDSIC,6) = FUELSHR(6) ! MSW
       ENDIF
       ENDDO ! end of almost infinite read loop
888    maxcogyr=yr !continue   ! branch after end of SICGEN file

C READ FROM THE EI-867 FILE FOR ELECTRICITY GENERATION
C FIRST INITIALIZE FUEL ARRAY

        FNAME='SICGEN'
        IUNIT10=FILE_MGR('O',FNAME,NEW)
        READ(IUNIT10,900)
        READ(IUNIT10,900)
       DO I=1,1901                  ! keep going until the end of file reached
       READ(IUNIT10,*,IOSTAT=IOS,END=903)IYEAR,ISIC,IC,PM,SOURCE,
     1     GEN,CONS
        IF(ISIC.EQ.1) INDSIC= 1
        IF(ISIC.EQ.2.OR.ISIC.EQ.7.OR.ISIC.EQ.8.OR.ISIC.EQ.9) INDSIC=2
        IF(ISIC.EQ.11.OR.ISIC.EQ.12) INDSIC=3
        IF(ISIC.EQ.13) INDSIC=4
        IF(ISIC.EQ.10.OR.ISIC.EQ.14) INDSIC=5
        IF(ISIC.EQ.15.OR.ISIC.EQ.16.OR.ISIC.EQ.17) INDSIC=6
        IF(ISIC.EQ.20) INDSIC=7
        IF(ISIC.EQ.26.OR.ISIC.EQ.2621.OR.ISIC.EQ.2631) INDSIC=8
       IF(ISIC.EQ.28.OR.ISIC.EQ.2821.OR.ISIC.EQ.2869.OR.ISIC.EQ.2873
     1  .OR.ISIC.EQ.2819)INDSIC=9
        IF(ISIC.EQ.3241) INDSIC=11
        IF(ISIC.EQ.3312) INDSIC=12
        IF(ISIC.EQ.3334) INDSIC=13
        IF(ISIC.EQ.34) INDSIC=14
        IF(ISIC.EQ.35) INDSIC=15

        IF(SOURCE.EQ.'COL') THEN
          IF = 1
        ELSE IF(SOURCE.EQ.'PET') THEN
          IF = 2
        ELSE IF(SOURCE.EQ.'GAS') THEN
          IF = 3
        ELSE IF(SOURCE.EQ.'WOD') THEN
          IF = 4
        ELSE IF(SOURCE.EQ.'OTH') THEN
          IF = 5
        ELSE IF(SOURCE.EQ.'MSW') THEN
          IF = 6
        ENDIF
         
        IF(PM.EQ.'GT') THEN
          IP=2
        ELSE IF(PM.EQ.'IC') THEN
         IP=1
        ELSE IF(PM.EQ.'ST'.OR.PM.EQ.'SF') THEN
          IP=3
        ELSE IF(PM.EQ.'HY') THEN
          IP=4
        ELSE
          IF(PRTDBGI.GE.2)WRITE(6,*)'WRONG TYPE ',PM
        ENDIF

        YR = IYEAR - 89


C ASSIGN VALUES TO ARRAY OF GENERATION FOR COGEN
       IF(INDSIC.LE.15)
     1    SICGEN(IC,YR,INDSIC,IF,IP,3) = GEN/1000.0


       ENDDO

903    CONTINUE ! branch to after end of SICGEN read



C OPEN FILE CONTAINING PLANNED CAPACITY VALUES

        FNAME='PLANCAP'
        IUNIT11=FILE_MGR('O',FNAME,NEW)
        READ(IUNIT11,900)                       ! skip the first line
        READ(IUNIT11,900)                       ! skip the second line
       DO I=1,380                               ! keep going until the end of file reached
        READ(IUNIT11,*,IOSTAT=IOS,END=38)IYEAR,ISIC,IC,PM,CAPACITY
        IF(ISIC.EQ.1) INDSIC= 1
        IF(ISIC.EQ.2.OR.ISIC.EQ.7.OR.ISIC.EQ.8.OR.ISIC.EQ.9) INDSIC=2
        IF(ISIC.EQ.11.OR.ISIC.EQ.12) INDSIC=3
        IF(ISIC.EQ.13) INDSIC=4
        IF(ISIC.EQ.10.OR.ISIC.EQ.14) INDSIC=5
        IF(ISIC.EQ.15.OR.ISIC.EQ.16.OR.ISIC.EQ.17) INDSIC=6
        IF(ISIC.EQ.20) INDSIC=7
        IF(ISIC.EQ.26.OR.ISIC.EQ.2621.OR.ISIC.EQ.2631) INDSIC=8
       IF(ISIC.EQ.28)INDSIC=9
        IF(ISIC.EQ.3241) INDSIC=11
        IF(ISIC.EQ.3312) INDSIC=12
        IF(ISIC.EQ.3334) INDSIC=13
        IF(ISIC.EQ.34) INDSIC=14
        IF(ISIC.GE.35) INDSIC=15

        IF(PM.EQ.'GT') THEN
          IP=2
        ELSE IF(PM.EQ.'IC') THEN
          IP=1
        ELSE IF(PM.EQ.'ST'.OR.PM.EQ.'SF') THEN
          IP=3
        ELSE IF(PM.EQ.'HY') THEN
          IP=4
        ELSE
          IF(PRTDBGI.GE.2)WRITE(6,*)'WRONG TYPE ',PM
        ENDIF

        YR = IYEAR - 89



C ASSIGN VALUES TO ARRAY OF PLANNED CAPACITY FOR COGEN
         IF(INDSIC.LE.15) THEN
           CAP867(IC,YR,INDSIC,IP) = CAPACITY
         ENDIF


        ENDDO
 38    MAXPLAN=YR ! CONTINUE ! Branch to at end of PLANCAP
      ENDIF

      ENDIF
 900  FORMAT(1X)
 901  FORMAT(I1,9X,I2,8X,I2,8X,F8.2,2X,A3,7X,A2)
C
      RETURN
C
100   IERR=6
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C    CALCULATE COGEN SHARES
C
      SUBROUTINE CALCGSH 
      IMPLICIT NONE
      INCLUDE(INDALL)

      COMMON/COGSHR/CAPSHR(9,6,2),GRDSHRG(4,15),prime(11,32,15,4)

      REAL CAPSHR,GRDSHRG
      REAL AVGUTL(10)
C  DECLARE INTERNAL VARIABLES

      REAL SMGEN(9,6,15)
      REAL TOTGEN(9,6)
      real prime ! division, year, inddir, prime mover
      INTEGER I,J,K,L
      INTEGER JYR

      JYR = IYR - 1989
C****
C  IF UTILIZATION RATE IS MISSING USE THE AVERAGE
C  UTILIZATION RATE FROM 1995 EIA-867
C****
       DATA AVGUTL/.6750,.6700,.6200,0.0,0.0,.4766,
     1    .6270,0.0,0.0,.6995/
       IF((IYR-1989).GT.MAXCOGYR) THEN
         AVGUTL(2) = .6500
       ENDIF

C****
C  COMPUTE SHARE OF OUTPUT BY FUEL BY DIVISION
C*****

C*****
C  First, calculate total output by division by fuel
C*****


       DO I = 1,9
        DO J = 1,6
          TOTGEN(I,J) = 0.0
        ENDDO
       ENDDO
       
       DO I = 1,4
        GRDSHRG(I,INDDIR) = 0.0
      ENDDO

C**
C  CALCULATE TOTAL GENERATION ACROSS ALL INDUSTRIES BY DIVISION
C  AND BY FUEL 
C**
       DO I = 1,9
         DO J = 1,6
          DO K = 1,15
             TOTGEN(I,J) = TOTGEN(I,J)+SICGEN(I,JYR,K,J,1,3)+
     1       SICGEN(I,JYR,K,J,2,3)+SICGEN(I,JYR,K,J,3,3)
          ENDDO
        ENDDO
       ENDDO



C**
C  CALCULATE SHARE OF GENERATION BY DIVISION BY FUEL
C**
      DO J = 1,6
      IF(TOTGEN(1,J)+TOTGEN(2,J).GT.(.00001))THEN
           TSHRGEN(1,J) = TOTGEN(1,J)/
     1       (TOTGEN(1,J)+TOTGEN(2,J))

           TSHRGEN(2,J) = TOTGEN(2,J)/
     1       (TOTGEN(1,J)+TOTGEN(2,J))
      ENDIF

      IF(TOTGEN(3,J)+TOTGEN(4,J).GT.(.00001))THEN
           TSHRGEN(3,J) =TOTGEN(3,J)/
     1       (TOTGEN(3,J)+TOTGEN(4,J))

           TSHRGEN(4,J) =TOTGEN(4,J)/
     1       (TOTGEN(3,J)+TOTGEN(4,J))
      ENDIF

      IF(TOTGEN(5,J)+TOTGEN(6,J)+
     1     TOTGEN(7,J).GT.(.00001)) THEN

           TSHRGEN(5,J) =TOTGEN(5,J)/
     1       (TOTGEN(5,J)+TOTGEN(6,J)+
     1       TOTGEN(7,J))

           TSHRGEN(6,J) =TOTGEN(6,J)/
     1       (TOTGEN(5,J)+TOTGEN(6,J)+
     1       TOTGEN(7,J))

           TSHRGEN(7,J) =TOTGEN(7,J)/
     1       (TOTGEN(5,J)+TOTGEN(6,J)+
     1       TOTGEN(7,J))
      ENDIF

      IF(TOTGEN(8,J)+TOTGEN(9,J).GT.(.00001)) THEN
           TSHRGEN(8,J) =TOTGEN(8,J)/
     1       (TOTGEN(8,J)+TOTGEN(9,J))

           TSHRGEN(9,J) =TOTGEN(9,J)/
     1       (TOTGEN(8,J)+TOTGEN(9,J))
      ENDIF
      ENDDO


C********
C     CALCULATE TOTAL GENERATION OWN/SALES, TOTAL CAPACITY
C********
C*****
C  First, calculate total output by division by fuel
C*****


       DO I = 1,9
         SMGEN(I,JYR,INDDIR) = 0.0
        DO J= 1,6
           SMGEN(I,JYR,INDDIR) = SMGEN(I,JYR,INDDIR) +
     1     SICGEN(I,JYR,INDDIR,J,1,3)+SICGEN(I,JYR,INDDIR,J,2,3)
     1     + SICGEN(I,JYR,INDDIR,J,3,3)+SICGEN(I,JYR,INDDIR,J,4,3)
        ENDDO
       ENDDO

C CALCULATE WEIGHTED AVERAGE GRIDSHARE BY REGION
      IF(SMGEN(1,JYR,INDDIR)+SMGEN(2,JYR,INDDIR).GT.0.0) THEN
       GRDSHRG(1,INDDIR) = (IGRIDSHR(1,JYR,INDDIR)*SMGEN(1,JYR,INDDIR)+
     1          IGRIDSHR(2,JYR,INDDIR)*SMGEN(2,JYR,INDDIR))/
     1          (SMGEN(1,JYR,INDDIR)+SMGEN(2,JYR,INDDIR))
      ENDIF

      IF(SMGEN(3,JYR,INDDIR)+SMGEN(4,JYR,INDDIR).GT.0.0) THEN
       GRDSHRG(2,INDDIR) = (IGRIDSHR(3,JYR,INDDIR)*SMGEN(3,JYR,INDDIR)+
     1            IGRIDSHR(4,JYR,INDDIR)*SMGEN(4,JYR,INDDIR))/
     1           (SMGEN(3,JYR,INDDIR)+SMGEN(4,JYR,INDDIR))
      ENDIF

      IF(SMGEN(5,JYR,INDDIR)+SMGEN(6,JYR,INDDIR)+
     1   SMGEN(7,JYR,INDDIR).GT.0.0) THEN
      GRDSHRG(3,INDDIR) = (IGRIDSHR(5,JYR,INDDIR)*SMGEN(5,JYR,INDDIR)+
     1               IGRIDSHR(6,JYR,INDDIR)*SMGEN(6,JYR,INDDIR)+
     1               IGRIDSHR(7,JYR,INDDIR)*SMGEN(7,JYR,INDDIR))/
     1   (SMGEN(5,JYR,INDDIR)+SMGEN(6,JYR,INDDIR)+SMGEN(7,JYR,INDDIR))
      ENDIF

      IF(SMGEN(8,JYR,INDDIR)+SMGEN(9,JYR,INDDIR).GT.0.0) THEN
       GRDSHRG(4,INDDIR) = (IGRIDSHR(8,JYR,INDDIR)*SMGEN(8,JYR,INDDIR)+
     1           IGRIDSHR(9,JYR,INDDIR)*SMGEN(9,JYR,INDDIR))/
     1           (SMGEN(8,JYR,INDDIR)+SMGEN(9,JYR,INDDIR))
      ENDIF

      RETURN
      END

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C    CALCULATE COGEN SHARES
c    routine is called every year
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE CAL_EI867 
      IMPLICIT NONE
      INCLUDE(INDALL)


C  DECLARE INTERNAL VARIABLES

      REAL TOTGEN(9,6)
      REAL AVGUTL(10)
      INTEGER I,J,JR,YR,K
      INTEGER L,M

C****
C  IF UTILIZATION RATE IS MISSING USE THE AVERAGE
C  UTILIZATION RATE FROM 1995 EIA-867
C****
       DATA AVGUTL/.6750,.6700,.6200,0.0,0.0,.4766,
     1    .6270,0.0,0.0,.6995/
       IF((IYR-1989).GT.MAXCOGYR) THEN
         AVGUTL(2) = .6500
       ENDIF

C******
C    CALCULATE SHARES OF ELECTRICITY GENERATION BY FUEL BY DIVSION
C    FROM THE EI-867 DATAFOR 1990 THROUGH 1995
C*******

C****
C  TOTAL ELECTRICITY GENERATION IS CALCULATED.
C****
       IF(INDREG.EQ.1) THEN
          L = 1
          M = 2
       ELSE IF(INDREG.EQ.2) THEN
          L = 3
          M = 4
       ELSE IF(INDREG.EQ.3) THEN
          L = 5
          M = 7
       ELSE IF(INDREG.EQ.4) THEN
          L = 8
          M = 9
       ENDIF


       YR = IYR - 1989
C***
C  IF YEAR 1996 THROUGH 1998, COMPUTE GENERATION FROM PLANNED
C  EI-867 UNITS USING UTILIZATION RATES
C****
       IF (IYR.GT.(MAXCOGYR+1989).AND.IYR.LE.(MAXPLAN+1989)) THEN
          DO I = L,M ! division
           DO J = 1,4 ! prime mover
            IF (FSTITER .EQ. 1) THEN

            CAP867(I,YR,INDDIR,J) = CAP867(I,YR,INDDIR,J)+
     1                     CAP867(I,YR-1,INDDIR,J)

       IF(CAP867(I,YR,INDDIR,J).LT.CAP867(I,YR-1,INDDIR,J))
     1    CAP867(I,YR,INDDIR,J) =  CAP867(I,YR-1,INDDIR,J)


            IF(CAP867(I,YR,INDDIR,J).GT.0.0.AND.
     1                 SICUTIL(I,5,INDDIR,J).EQ.0.0) THEN
              SICUTIL(I,5,INDDIR,J) = AVGUTL(J)
            ENDIF
       ENDIF

          DO K = 1,6 ! fuel
            SICGEN(I,YR,INDDIR,K,J,3) =(CAP867(I,YR,INDDIR,J)*
     1         SHARE(J,I,5,INDDIR,K)*
     1           SICUTIL(I,5,INDDIR,J)*(365.25*24.0))*.001

            IF(SICGEN(I,YR,INDDIR,K,J,3).LT.
     1         SICGEN(I,YR-1,INDDIR,K,J,3)) THEN
             SICGEN(I,YR,INDDIR,K,J,3) =
     1        SICGEN(I,YR-1,INDDIR,K,J,3)
             ENDIF
           ENDDO ! DO K = 1,6 ! fuel
          ENDDO  ! DO J = 1,3 ! prime mover
         ENDDO   ! DO I = L,M ! division
       ENDIF


       RETURN
       END

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRNEIELAS READS THE ELASTICITY AND OTHER DATA FOR THE
C     NON-ENERGY INTENSIVE INDUSTRIES.  (THE ENERGY INTENSIVE
C     INDUSTRIES DON'T USE ELASTICITY DATA.)
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRNEIELAS(ISTR,IOS,IERR)
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
C
      CHARACTER *200 ISTR
      INTEGER *4 IOS
      INTEGER IFL,J,IERR,IFX,IEQ,IVINT,ISTP,IDUM
      REAL TEMP(20)
C
      IERR=0
C
C   IDUM IS THE FUEL SEQUENCE NUMBER--NOT ACTUALLY USED
C
      READ(ISTR,*,ERR=100,IOSTAT=IOS) IDUM,IFX,IEQ,IVINT,
     1    (TEMP(J),J=1,14)
C
C   COUNT FUELS AND STORE FUEL NUMBERS, EQUATION TYPES, AND OTHER
C     VALUES IN THE APPROPRIATE ARRAY POSITIONS
C
      ISTP=1                             ! NEI INDUSTRIES HAVE 1 STEP
      IF(IFMAX(ISTP).GT.0) THEN
        DO IFL=1,IFMAX(ISTP)
          IF(IFX.EQ.IFLOC(IFL,ISTP)) GO TO 15
        ENDDO
      ENDIF
      IFMAX(ISTP)=IFMAX(ISTP)+1
      IFL=IFMAX(ISTP)
      IFLOC(IFL,ISTP)=IFX
      ITYPE(IFL,ISTP)=IEQ
15    CONTINUE
C
      ENPINT(IVINT,IFL,ISTP)=TEMP(1) ! Old Way
      EINTER(IVINT,IFL,ISTP)=TEMP(2)
      BCSC(IVINT,IFL,ISTP)  =TEMP(3)
      IF(INDDIR.GE.7.AND.INDDIR.LE.13) THEN
        ENPINT(IVINT,IFL,ISTP)= EINTER(IVINT,IFL,ISTP)
      ENDIF
C
C  SET VINTAGE 2 VALUES EQUAL TO VINTAGE 3 VALUES
C
      IF(IVINT.EQ.3) THEN
        ENPINT(2,IFL,ISTP)=ENPINT(3,IFL,ISTP)
        BCSC(2,IFL,ISTP)  =BCSC(3,IFL,ISTP)
      ENDIF
C
      DO J=1,11
        BELAS(IVINT,IFL,ISTP,J)=TEMP(J+3)
C
C       SET VINTAGE 2 VALUES EQUAL TO VINTAGE 3 VALUES
C
        IF(IVINT.EQ.3) BELAS(2,IFL,ISTP,J)=TEMP(J+3)
      ENDDO
      RETURN
C
100   IERR=7
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRSTEPBYP READS BYPRODUCT DATA PER PROCESS/ASSEMBLY
C     STEP IF THE INDUSTRY PRODUCES BYPRODUCTS IN THAT COMPONENT.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRSTEPBYP(ISTR,IOS,IERR,IFLAG)
      IMPLICIT NONE
      INCLUDE(INDCTRL)     
      INCLUDE(INDPA)     
C
      CHARACTER*200 ISTR,ISTR2
      CHARACTER*8 TNAME, ISTPN(30)
      INTEGER*4 IOS
      INTEGER IFL,J,IERR,IDUM,IFX,ISTP,IFLAG
      REAL TEMP(4)
C
      IERR=0
C
C   FIRST READ IS FORMATTED TO READ CHARACTER DATA
C
      READ(ISTR,1,ERR=100,IOSTAT=IOS) TNAME,ISTR2
1     FORMAT(A8,1X,A191)
C
C   SECOND READ IS UNFORMATTED; IDUM IS THE SEQUENCE NUMBER--NOT USED
C
      READ(ISTR2,*,ERR=100,IOSTAT=IOS) IDUM,IFX,
     1 (TEMP(J),J=1,4)
C
C   ASSIGN THE VALUES IN INDSTEPNAME TO AN 8 CHARACTER ARRAY,
C     CHECK FOR A VALID STEP NAME, AND FIND THE STEP NUMBER
C
      DO J=1,MPASTP
      ISTPN(J)=INDSTEPNAME(J)
      ENDDO
C
      CALL ICHECK(IFLAG,MPASTP,ISTPN,TNAME,ISTP)
      IF(IFLAG.EQ.0) THEN                   ! INVALID STEP NAME
        WRITE(6,5) INDNAME, TNAME
5       FORMAT(1X,'SUB_IRSTEPBYP WARNING:  ',A8,' HAS NO STEP '
     1         ,A8,' SKIP RECORD')
        RETURN
      ENDIF
C
C   COUNT FUELS FOR STEP ISTP, STORE FUEL NUMBER AND OTHER VALUES
C     IN THE APPROPRIATE POSITION OF THE ARRAYS.
C
      IFBYP(ISTP)=IFBYP(ISTP)+1
      IFL=IFBYP(ISTP)
      IFLOCBY(IFL,ISTP)=IFX
C
      BYPINT(1,IFL,ISTP)=TEMP(1)
      BYPCSC(1,IFL,ISTP)=TEMP(2)
C
C  SET VINTAGE 2 VALUES EQUAL TO VINTAGE 3 VALUES
C
      DO J=2,3
        BYPINT(J,IFL,ISTP)=TEMP(3)
        BYPCSC(J,IFL,ISTP)=TEMP(4)
      ENDDO
C
      DO J=1,3
        BYPINTLAG(J,IFL,ISTP)=BYPINT(J,IFL,ISTP)
      ENDDO
      RETURN
C
100   IERR=8
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IRSTEPDAT READS THE STEP DATA FOR THE ENERGY INTENSIVE
C     INDUTRIES.  (NON-ENEGRY INTENSIVE INDUSTRIES ONLY HAVE 1 STEP)
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IRSTEPDAT(ISTR,IOS,IERR,IFLAG)
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
C
      CHARACTER *200 ISTR,ISTR2
      CHARACTER *8 TNAME, ISTPN(30)
      INTEGER *4 IOS
      INTEGER IFL,J,IERR,IFX,IEQ,IVINT,ISTP,IFLAG,IDUM
      REAL TEMP(3)
C
      IERR=0
C
C  FIRST READ IS FORMATTED TO READ CHARACTER DATA
C
      READ(ISTR,1,ERR=100,IOSTAT=IOS) TNAME,ISTR2
1     FORMAT(A8,1X,A191)
C
C   SECOND READ IS UNFORMATTED; IDUM IS THE SEQUENCE NUMBER--NOT USED
C
      READ(ISTR2,*,ERR=100,IOSTAT=IOS) IDUM,IFX,IEQ,IVINT,
     1 (TEMP(J),J=1,3)
C
C   STORE STEP NAMES IN 8 CHARACTER ARRAY,
C     CHECK FOR A VALID STEP NAME, AND FIND STEP NUMBER
C
      DO J=1,MPASTP
      ISTPN(J)=INDSTEPNAME(J)
      ENDDO
C
      CALL ICHECK(IFLAG,MPASTP,ISTPN,TNAME,ISTP)
      IF(IFLAG.EQ.0) THEN                   ! INVALID STEP NAME
        WRITE(6,5) INDNAME, TNAME
5       FORMAT(1X,'SUB_IRSTEPDAT WARNING:  ',A8,' HAS NO STEP '
     1         ,A8,' SKIP RECORD')
        RETURN
      ENDIF
C
C   COUNT FUELS FOR STEP ISTP, STORE FUEL NUMBERS AND EQUATION TYPES
C
      IF(IFMAX(ISTP).GT.0) THEN
        DO IFL=1,IFMAX(ISTP)
          IF(IFX.EQ.IFLOC(IFL,ISTP)) GO TO 15
        ENDDO
      ENDIF
      IFMAX(ISTP)=IFMAX(ISTP)+1
      IFL=IFMAX(ISTP)
      IFLOC(IFL,ISTP)=IFX
      ITYPE(IFL,ISTP)=IEQ
15    CONTINUE
C
      ENPINT(IVINT,IFL,ISTP)=TEMP(1)
      EINTER(IVINT,IFL,ISTP)=TEMP(2)
      BCSC(IVINT,IFL,ISTP)  =TEMP(3)
C
C  SET VINTAGE 2 VALUES EQUAL TO VINTAGE 3 VALUES
C
      IF(IVINT.EQ.3) THEN
        ENPINT(2,IFL,ISTP)=TEMP(1)
        BCSC(2,IFL,ISTP)  =TEMP(3)
      ENDIF
C
      RETURN
C
100   IERR=9
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IFINLCHECK CHECKS FOR 1 .HEADER RECORD AND THE CORRECT 
C     NUMBER OF .STEPDEF, COGEN, NEIELAS, AND EISTEP RECORDS FOR
C     EACH REGION OF EACH INDUSTRY AND STORES THE INDUSTRY NAME.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IFINLCHECK(IFLAG,INDNAME,NREG,IHEADER,ISTEPDEF,
     1  MPASTP,ICOGEN,EIFLAG,INEIELAS,IEISTEP,IFMAX,INAMECK,
     2  INDDIR,NUMIND)
      IMPLICIT NONE
      INTEGER IFLAG,NREG,IHEADER,ISTEPDEF,
     1  MPASTP,ICOGEN,INEIELAS,IEISTEP,IFMAX(30),
     2  INDDIR,NUMIND,ITMP,I,EIFLAG
      CHARACTER *8 INDNAME,INAMECK(NUMIND)
C
      IFLAG=0
C
C   MUST BE ONE AND ONLY ONE .HEADER RECORD PER FILE SUBSECTION
C
      IF(IHEADER.NE.1)THEN
        IFLAG=IFLAG+1
        WRITE(6,1) INDNAME,NREG,IHEADER
      ENDIF
C
C   NUMBER OF .STEPDEF RECORDS MUST MATCH NUMBER OF P/A STEPS
C
      IF(ISTEPDEF.NE.MPASTP) THEN
        IFLAG=IFLAG+1
        WRITE(6,2) INDNAME,NREG,ISTEPDEF,MPASTP
      ENDIF
C
C   NO MORE THAN ONE COGEN RECORD PER FILE SUBSECTION
C
      IF(ICOGEN.GT.1) THEN
        IFLAG=IFLAG+1
        WRITE(6,3) INDNAME,NREG,ICOGEN
      ENDIF
C
C   IF ENERGY INTENSIVE INDUSTRY, MUST BE TWO EISTEP RECORDS FOR
C     EACH FUEL OF EACH PROCESS STEP, VINTAGE 1 AND 3.
C   IF NON-ENERGY INTENSIVE INDUSTRY, MUST BE TWO NEIELAS RECORDS
C     FOR EACH FUEL, VINTAGE 1 AND 3.
C
      IF(EIFLAG.EQ.1) THEN
        ITMP=0
        DO I=1,MPASTP
          ITMP=ITMP+IFMAX(I)
        ENDDO
        ITMP=ITMP*2
        IF(IEISTEP.NE.ITMP) THEN
          WRITE(6,4) INDNAME, NREG,IEISTEP,ITMP
          IFLAG=IFLAG+1
        ENDIF
      ELSE
        ITMP=IFMAX(1)*2
        IF(INEIELAS.NE.ITMP) THEN
          WRITE(6,5) INDNAME, NREG,INEIELAS,ITMP
          IFLAG=IFLAG+1
        ENDIF
      ENDIF
      IF(IFLAG.NE.0) WRITE(6,6)INDNAME,NREG,IFLAG
      IF(IFLAG.EQ.0) INAMECK(INDDIR)=INDNAME
C
1     FORMAT(1X,'SUB_IFINLCHECK ERROR:  ',A8,' REGION '
     1       ,I3,' HAS ',I3,' .HEADER')
2     FORMAT(1X,'SUB_IFINLCHECK ERROR:  ',A8,' REGION '
     1       ,I3,' HAS ',I3,' .STEPDEF,',
     2       ' SHOULD HAVE ',I3)
3     FORMAT(1X,'SUB_IFINLCHECK ERROR:  ',A8,' REGION '
     1       ,I3,' HAS ',I3,' COGEN,',
     2       ' SHOULD HAVE 0 OR 1')
4     FORMAT(1X,'SUB_IFINLCHECK ERROR:  ',A8,' REGION '
     1       ,I3,' HAS ',I3,' EISTEP,',
     2       ' SHOULD HAVE ',I5)
5     FORMAT(1X,'SUB_IFINLCHECK ERROR:  ',A8,' REGION '
     1       ,I3,' HAS ',I3,' NEIELAS,',
     2       ' SHOULD HAVE ',I5)
6     FORMAT(1X,'SUB_IFINLCHECK NOTE:  ',A8,' REGION '
     1       ,I3,' HAS',I3,' ERROR(S) AS ',
     2       'INDICATED ABOVE.  CORRECT AND RE-EXECUTE')
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IFINLCALC CALCULATES SELECTED VALUES AT THE END OF
C     REGIONAL DATA FOR EACH INDUSTRY.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IFINLCALC
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDBSC)
      INCLUDE(INDMACRO)
C
C   DECLARE INTERNAL VARIABLES
C
      INTEGER IS,IX,IZ,IC
      REAL PRODSUM(30,5),BTEMP
C
C
C****
C  THE PRODUCTION THROUGHPUT FOR EACH STEP IS CALCULATED.
C****
C
      DO 100 IS=1,MPASTP
        PRODCUR(4,IS)=0.0
        DO 85 IC=1,NTMAX(IS)
          IF(IPASTP(IS,IC).EQ.0) THEN
            PRODSUM(IS,IC)=PRODFLOW(1,IS,IC)*
     1                         PRODX(INDDIR,INDREG)
          ELSE
            PRODSUM(IS,IC)=PRODFLOW(1,IS,IC)*
     1                      PRODCUR(4,IPASTP(IS,IC))
          ENDIF
          PRODCUR(4,IS)=PRODCUR(4,IS)+PRODSUM(IS,IC)
 85   CONTINUE
      PRODCUR(1,IS)=PRODCUR(4,IS)
  100 CONTINUE
C
C   COMPUTE THE SHARE OF TOTAL FUEL CONSUMPTION FOR EACH FUEL
C
      BTEMP=0.0
      DO IS=1,IFSMAX
        BTEMP=BTEMP+BSSHR(IS)
      ENDDO
      DO IS=1,IFSMAX
        BSSHR(IS)=BSSHR(IS)/BTEMP
      ENDDO
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   SUBROUTINE IZEROOUT INITIALIZES VARIABLES FOR EACH REGION
C     OF EACH INDUSTRY.  VARIABLES ARE INITIALIZED TO BLANK,
C     ZERO, OR ONE.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
      SUBROUTINE IZEROOUT(ITAG,NLASTREG,ISTP,NSTEP,IEQ,IFPX,NFUELS,
     1    IFUEL,LINDNAME,IHEADER,ISTEPDEF,ICOGEN,INEIELAS,IEISTEP)
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDBLD)
      INCLUDE(INDMACRO)
      INCLUDE(INDBSC)
      INCLUDE(INDCOGEN)
C
C   DECLARE LOCAL VARIABLES 
C
      INTEGER NLASTREG,ISTP,NSTEP,IEQ,IFPX,NFUELS,IFUEL,I,J,K,L,
     1   IHEADER,ISTEPDEF,ICOGEN,INEIELAS,IEISTEP
      CHARACTER *8 ITAG,LINDNAME
C
C   INITIALIZE VARIABLES TO ZERO, BLANK, OR ONE AS APPROPRIATE
C
      INDNAME= '        '
      LINDNAME='        '
      INDREG=  0
      ITAG=    '        '
      INDDIR=  0
      IDVAL=   0
      PHDRAT=  0.0
      CUMOUT88=0.0
      STEMCUR= 0.0
      MPASTP = 0
      ISTP=    0
      NLASTREG=0
      NSTEP   =0
      IEQ     =0
      IFPX    =0
      NFUELS  =0
      IFUEL   =0
      IHEADER =0
      ISTEPDEF=0
      ICOGEN  =0
      INEIELAS=0
      IEISTEP =0
      IFSMAX  =0
      IFSBYP  =0
      GSTEAM  =0.0
      GEN90   =0.0
C
      DO 10 J=1,10
       NTMAX(J)=0
       PRODRETR(J)=0.0
       INDSTEPNAME(J)='        '
       IFMAX(J)=0
       IFBYP(J)=0
       DO 10 K=1,5
        IPASTP(J,K)=0
10    CONTINUE
C
      DO 15 I=1,2
       DO 15 J=1,10
        DO 15 K=1,5
          PRODFLOW(I,J,K)=0.0
15    CONTINUE
C
C
      DO 25 I=1,3
       DO 25 J=1,15
        DO 25 K=1,10
         ENPINT(I,J,K)=0.0
         EINTER(I,J,K)=0.0
         BCSC(I,J,K)=0.0
         CSCCUR(I,J,K)=1.0        ! CSC VALUES INITIALIZE TO 1.0
         CSCLAG(I,J,K)=1.0
         PRCCUR(I,J,K)=1.0        ! PRC VALUES INITIALIZE TO 1.0
         PRCLAG(I,J,K)=1.0
25    CONTINUE
C
      DO 30 I=1,3
       DO 30 J=1,15
        DO 30 K=1,10
         DO 30 L=1,11
          BELAS(I,J,K,L)=0.0
30    CONTINUE
C
      DO 35 I=1,3
       DO 35 J=1,5
        DO 35 K=1,10
          BYPINT(I,J,K)=0.0
          BYPCSC(I,J,K)=0.0
          BYPCSCCUR(I,J,K)=1.0    ! CSC VALUES FOR BYPRODUCT
          BYPCSCLAG(I,J,K)=1.0    !   START AT 1.0
35    CONTINUE
C
      DO 40 I=1,2
       DO 40 J=1,3
         ENBINT(I,J)=0.0
         BBCSC(I,J)=0.0
         BBELAS(I,J)=0.0
40    CONTINUE
C
      DO 50 I=1,10
        IFSLOC(I)=0
        BSSHR(I)=0.0
        ENSINT(I)=0.0
50    CONTINUE
C
      DO 55 I=1,6
        IFSLOCBY(I)=0
        BYSINT(I)=0.0
        BYBSCSC(I)=0.0
55    CONTINUE
C
      DO 60 I=1,4
        GENEQPHTRT(I)=0.0
60    CONTINUE
C
      DO 65 I=1,15
       DO 65 J=1,10
        IFLOC(I,J)=0
65    CONTINUE
C
      RETURN
      END
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE WRITES ALL NECESSARY VARIABLES FOR LAG,
C  INITIALIZATION AND REPORT WRITING PURPOSES TO BUFFERS FOR
C  TWO UNFORMATTED FILES.  INDBIN1 CONTAINS INFORMATION
C  FOR EACH INDUSTRY THAT DO NOT CHANGE FROM YEAR TO YEAR.
C  INDBIN2 CONTAINS INFORMATION THAT CHANGES FROM YEAR TO
C YEAR FOR EACH INDUSTRY.
C****
      SUBROUTINE WRBIN
      IMPLICIT NONE
      INCLUDE(INDALL)
C VARIABLES FOR BUFFERS TO HOLD ALTERNATIVE TO DIRECT ACCESS RECORDS
      INCLUDE(INDBFC1)

      DIMENSION IPASTPZ(5),IFLOCZ(15),BCSCZ(3,15),BELASZ(3,15,11)
      DIMENSION ITYPEZ(15),EINTERZ(3,15)
      DIMENSION PRODCURZ(4),PRODLAGZ(4),PRODFLWZ(2,5),CSCCURZ(3,15),
     1 CSCLAGZ(3,15),PRCCURZ(3,15),PRCLAGZ(3,15),ENPINTZ(3,15),
     2 ENPQTYZ(4,15),IDLCAPZ(10),PRODZEROZ(4)
      DIMENSION IFLOCBYZ(5),BYPCSCZ(3,5)
      DIMENSION BYPCSCCURZ(3,5),
     1 BYPCSCLAGZ(3,5),BYPINTZ(3,5),
     2 BYPQTYZ(4,6)
      INTEGER IREC,IY,IV,IS,IT,IF,J,LENGTHSUM,JF,ITA
      INTEGER IP
      INTEGER NTMAXZ,IFMAXZ,IPASTPZ,IFLOCZ,IFBYPZ,ITYPEZ
      REAL BCSCZ,BELASZ,PRODCURZ,PRODLAGZ,PRODFLWZ,CSCCURZ,CSCLAGZ,
     1 PRCCURZ,PRCLAGZ,ENPINTZ,ENPQTYZ,PRODRTRZ,EINTERZ,IDLCAPZ,
     2 PRODZEROZ
      INTEGER IFLOCBYZ
      REAL BYPCSCCURZ,BYPCSCZ,
     1 BYPCSCLAGZ,BYPINTZ,
     2 BYPQTYZ
      REAL REGPRCX(50),REGPRODVX(15),REGPRODX(15),REGEMPLX(15)
      CHARACTER*8 A8
C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  WRITE CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C  CHANGE FROM YEAR TO YEAR BUT DO CHANGE FROM INDUSTRY TO INDUSTRY
C  TO INDBIN1 BUFFER.
C****

C****
C    WRITE CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C    CHANGE FROM YEAR TO YEAR AND PROCESS TO PROCESS
C    TO FIRST INDBIN1 BUFFER.
C    EACH INDUSTRY WILL HAVE ONE RECORD.
C****

      IF(IYR.EQ.IBYR) THEN
        LENGTHIND(INDNUM)=MPASTP+1
      ENDIF
      IF(INDNUM.EQ.1)THEN
        IREC=1
      ELSE
        IREC=1
        DO 5 J=1,INDNUM-1
          IREC=IREC+LENGTHIND(J)
  5     CONTINUE
      ENDIF
      IF(FSTITER.EQ.1.AND.IYR.LE.IBYR+1) THEN
       IF(INDNUM.LE.NUMIND) THEN
         WRITE(A8,'(A4,I4)') 'TEST',NUMB1I
         WRITE(B1ICUR(INDNUM,INDREG),992)
     1   INDMAX,MPASTP,PHDRAT,INDDIR,
     2   LENGTHIND,IDVAL,
     4   BBCSC,BBELAS,BBEMPL,IFSMAX,IFSLOC,
     6   INDNAME,INDSTEPNAME,IFSBYP,IFSLOCBY,
     7   BYBSCSC,GINTER,GSTEAM,
     8   GENEQPHTRT,
     9   CUMOUT88,A8
         IF(A8.NE.B1ICUR(INDNUM,INDREG)(NUMB1I-7:NUMB1I))THEN
           WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. WRBIN'
           WRITE(6,'(1X,5A)') 'B1ICUR"',A8,'" DOESN''T MATCH "',
     1     B1ICUR(INDNUM,INDREG)(NUMB1I-7:NUMB1I),'"'
         ENDIF
       ELSE
         WRITE(6,*) 'NUMIND DIM TOO SMALL IN SUBR. WRBIN:',
     1   NUMIND,INDNUM
       ENDIF
C****
C    WRITE CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C    CHANGE FROM YEAR TO YEAR AND BUT CHANGES FROM PROCESS TO
C    PROCESS TO SECOND INDBIN1 BUFFER.
C    EACH RECORD WILL CONTAIN PROCESS-SPECIFIC INFO.
C    THE NUMBER OF RECORDS FOR AN INDUSTRY WILL BE THE NUMBER OF
C    PROCESS STEPS FOR THAT INDUSTRY.
C****

       DO 50 IS=1,MPASTP
        IREC=IREC+1
        NTMAXZ=NTMAX(IS)
        IFMAXZ=IFMAX(IS)
        IFBYPZ=IFBYP(IS)
        DO 45 IT=1,5
          IPASTPZ(IT)=IPASTP(IS,IT)
   45   CONTINUE
        DO 49 IF=1,15
          IFLOCZ(IF)=IFLOC(IF,IS)
          ITYPEZ(IF)=ITYPE(IF,IS)
          DO 47 IT=1,3
            BCSCZ(IT,IF)=BCSC(IT,IF,IS)
            EINTERZ(IT,IF)=EINTER(IT,IF,IS)
            DO 46 JF=1,11
              BELASZ(IT,IF,JF)=BELAS(IT,IF,IS,JF)
   46       CONTINUE
   47     CONTINUE
   49   CONTINUE
        DO 48 IF=1,5
          IFLOCBYZ(IF)=IFLOCBY(IF,IS)
          DO 485 IT=1,3
            BYPCSCZ(IT,IF)=BYPCSC(IT,IF,IS)
  485     CONTINUE
   48   CONTINUE
        IP=IREC-INDNUM
        IF(IP.LE.NUMPROC.AND.IP.GE.1) THEN
         WRITE(A8,'(A4,I4)') 'TEST',NUMB1P
         WRITE(B1PCUR(IP,INDREG),992)
     1   INDDIR,NTMAXZ,IFMAXZ,IPASTPZ,IFLOCZ,
     2   ITYPEZ,BCSCZ,BELASZ,IFBYPZ,IFLOCBYZ,BYPCSCZ,EINTERZ,A8
         IF(A8.NE.B1PCUR(IP,INDREG)(NUMB1P-7:NUMB1P))THEN
           WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. WRBIN'
           WRITE(6,'(1X,5A)') 'B1PCUR"',A8,'" DOESN''T MATCH "',
     1     B1PCUR(IP,INDREG)(NUMB1P-7:NUMB1P),'"'
         ENDIF
        ELSE
          WRITE(6,*) 'NUMPROC DIM TOO SMALL IN SUBR. WRBIN:',
     1     NUMPROC,IP
        ENDIF
 50    CONTINUE
      ENDIF

C****
C  WRITE THE VARIABLES THAT CONTAIN RESULTS THAT CHANGE FROM YEAR
C  TO YEAR AND FROM INDUSTRY TO INDUSTRY TO THE INDBIN2 BUFFER.
C  THIS IS NOW DONE ONLY ON THE LAST ITERATION (LSTITER.EQ.1)
C****

C****
C    WRITE THE VARIABLES THAT ARE NOT PROCESS SPECIFIC.
C****
      IF(LSTITER.EQ.1) THEN
      IY=IYR-1990
      IF(IYR.EQ.IBYR) THEN
        IF(INDNUM.EQ.1) THEN
          IREC=1
        ELSE
          IREC=1
          DO 120 J=1,INDNUM-1
            IREC=IREC+LENGTHIND(J)
120       CONTINUE
        ENDIF
      ENDIF
      IF(IYR.GT.IBYR) THEN
         LENGTHSUM=0
         DO 125 J=1,INDMAX
            LENGTHSUM=LENGTHSUM+LENGTHIND(J)
125      CONTINUE
         IREC=(IY)*LENGTHSUM
         IF(INDNUM.EQ.1) THEN
           IREC=IREC+1
         ELSE
           DO 130 J=1,INDNUM-1
             IREC=IREC+LENGTHIND(J)
130        CONTINUE
           IREC=IREC+1
         ENDIF
      ENDIF
      DO J=1,50
        REGPRCX(J)=PRCX(J,INDREG)
      ENDDO
      DO J=1,15
        REGPRODVX(J)=PRODVX(J,INDREG)
        REGPRODX(J)=PRODX(J,INDREG)
        REGEMPLX(J)=EMPLX(J,INDREG)
      ENDDO
      IF(INDNUM.LE.NUMIND) THEN
         WRITE(A8,'(A4,I4)') 'TEST',NUMB2I
         WRITE(B2ICUR(INDNUM,INDREG),992)
     2   INDDIR,ENPMQTY,ENPIQTY,ENPRQTY,REGPRODX,REGEMPLX,
     2   REGPRCX,REGPRODVX,
     3   ENBINT,ENBQTY,ENSINT,ENSQTY,BSSHR,STEMCUR,ELGEN,
     4   ELOWN,ELSALE,GENFUEL,BYSINT,QTYMAIN,QTYINTR,QTYRENW,
     5   BYPBSCM,BYPBSCI,BYPBSCR,A8
         IF(A8.NE.B2ICUR(INDNUM,INDREG)(NUMB2I-7:NUMB2I))THEN
           WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. WRBIN'
           WRITE(6,'(1X,5A)') 'B2ICUR"',A8,'" DOESN''T MATCH "',
     1     B2ICUR(INDNUM,INDREG)(NUMB2I-7:NUMB2I),'"'
         ENDIF
      ELSE
         WRITE(6,*) 'NUMIND DIM TOO SMALL IN SUBR. WRBIN:',
     1   NUMIND,INDNUM
      ENDIF

C****
C    WRITE THE VARIABLES THAT ARE PROCESS SPECIFIC.
C****

      DO 200 IS=1,MPASTP
        IREC=IREC+1
        PRODRTRZ=PRODRETR(IS)
        IDLCAPZ(IS)=IDLCAP(IS)
        DO 101 IV=1,4
          PRODCURZ(IV)=PRODCUR(IV,IS)
          PRODLAGZ(IV)=PRODLAG(IV,IS)
          PRODZEROZ(IV)=PRODZERO(IV,IS)
  101   CONTINUE
        DO 103 IT=1,5
          DO ITA=1,2
            PRODFLWZ(ITA,IT)=PRODFLOW(ITA,IS,IT)
          ENDDO
  103   CONTINUE
        DO 109 IF=1,15
          DO 107 IV=1,3
            CSCCURZ(IV,IF)=CSCCUR(IV,IF,IS)
            CSCLAGZ(IV,IF)=CSCLAG(IV,IF,IS)
            PRCCURZ(IV,IF)=PRCCUR(IV,IF,IS)
            PRCLAGZ(IV,IF)=PRCLAG(IV,IF,IS)
            ENPINTZ(IV,IF)=ENPINT(IV,IF,IS)
            ENPQTYZ(IV,IF)=ENPQTY(IV,IF,IS)
  107     CONTINUE
          ENPQTYZ(4,IF)=ENPQTY(4,IF,IS)
  109   CONTINUE
        DO 111 IF=1,5
          DO 110 IV=1,3
            BYPCSCCURZ(IV,IF)=BYPCSCCUR(IV,IF,IS)
            BYPCSCLAGZ(IV,IF)=BYPCSCLAG(IV,IF,IS)
            BYPINTZ(IV,IF)=BYPINT(IV,IF,IS)
  110     CONTINUE
  111   CONTINUE
        DO IF=1,6
          DO IV=1,4
            BYPQTYZ(IV,IF)=BYPQTY(IV,IF,IS)
          ENDDO
        ENDDO
        IP=IREC-(IY*LENGTHSUM)-INDNUM
        IF(IP.LE.NUMPROC.AND.IP.GE.1) THEN
          WRITE(A8,'(A4,I4)') 'TEST',NUMB2P
          WRITE(B2PCUR(IP,INDREG),992)
     1    INDDIR,IS,PRODRTRZ,PRODCURZ,PRODLAGZ,PRODZEROZ,
     1    PRODFLWZ,CSCCURZ,CSCLAGZ,PRCCURZ,PRCLAGZ,ENPINTZ,ENPQTYZ,
     3    BYPCSCCURZ,BYPCSCLAGZ,BYPINTZ,BYPQTYZ,IDLCAPZ,A8
          IF(A8.NE.B2PCUR(IP,INDREG)(NUMB2P-7:NUMB2P))THEN
            WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. WRBIN'
            WRITE(6,'(1X,5A)') 'B2PCUR"',A8,'" DOESN''T MATCH "',
     1      B2PCUR(IP,INDREG)(NUMB2P-7:NUMB2P),'"'
          ENDIF
        ELSE
          WRITE(6,*) 'NUMPROC DIM TOO SMALL IN SUBR. WRBIN:',
     1    NUMPROC,IP
        ENDIF
 200  CONTINUE
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'WRBIN')
992   FORMAT(255A,255A,255A,255A,255A,255A,255A)
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE READS ALL NECESSARY VARIABLES FOR LAG,
C  INITIALIZATION PURPOSES FROM THE BUFFERS FOR TWO
C  UNFORMATTED FILES.  THE 2 INDBIN1 BUFFERS CONTAIN INFORMATION
C  FOR EACH INDUSTRY THAT DO NOT CHANGE FROM YEAR TO YEAR.
C  THE 2 INDBIN2 BUFFERS CONTAIN INFORMATION THAT CHANGE FROM YEAR TO
C  YEAR FOR EACH INDUSTRY.
C****
      SUBROUTINE RDBIN
      IMPLICIT NONE
      INCLUDE(INDALL)
C VARIABLES FOR BUFFERS TO HOLD ALTERNATIVE TO DIRECT ACCESS RECORDS
      INCLUDE(INDBFC1)

      DIMENSION IPASTPZ(5),IFLOCZ(15),BCSCZ(3,15),BELASZ(3,15,11)
      DIMENSION ITYPEZ(15),EINTERZ(3,15)
      DIMENSION PRODCURZ(4),PRODLAGZ(4),PRODFLWZ(2,5),CSCCURZ(3,15),
     1 CSCLAGZ(3,15),PRCCURZ(3,15),PRCLAGZ(3,15),ENPINTZ(3,15),
     2 ENPQTYZ(4,15),IDLCAPZ(10),PRODZEROZ(4)
      DIMENSION IFLOCBYZ(5),BYPCSCZ(3,5)
      DIMENSION BYPCSCCURZ(3,5),
     1 BYPCSCLAGZ(3,5),BYPINTZ(3,5),
     2 BYPQTYZ(4,6)
      INTEGER IREC,IY,IV,IS,IT,IF,J,LENGTHSUM,ISZ,JF,NY,ITA
      INTEGER NTMAXZ,IFMAXZ,IPASTPZ,IFLOCZ,ITYPEZ
      REAL BCSCZ,BELASZ,PRODCURZ,PRODLAGZ,PRODFLWZ,CSCCURZ,CSCLAGZ,
     1 PRCCURZ,PRCLAGZ,ENPINTZ,ENPQTYZ,PRODRTRZ,EINTERZ,IDLCAPZ,
     2 PRODZEROZ
      INTEGER IFLOCBYZ,IFBYPZ
      REAL BYPCSCCURZ,BYPCSCZ,
     1 BYPCSCLAGZ,BYPINTZ,
     2 BYPQTYZ
      REAL REGPRCX(50),REGPRODVX(15),REGPRODX(15),REGEMPLX(15)
      INTEGER DUMB(50)
      REAL QTYMTEMP(23,5),QTYRTEMP(9,5),QTYITEMP(7,5)
      INTEGER IP
      CHARACTER*8 A8
C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  READ PROCESS CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C  CHANGE FROM YEAR TO YEAR BUT DO CHANGE FROM INDUSTRY TO INDUSTRY
C  FROM THE FIRST INDBIN1 BUFFER.
C  THE YEAR THAT IS READ IS THE LAG YEAR.
C****

C****
C    READ PROCESS CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C    CHANGE FROM YEAR TO YEAR BUT DO CHANGE FROM INDUSTRY TO INDUSTRY
C    FROM RESTART FILE ONE.  THIS PART INCLUDES NON-PROCESS
C    SPECIFIC INFORMATION FOR THE INDUSTRY.
C****

      IF(INDNUM.EQ.1)THEN
        IREC=1
      ELSE
        IREC=1
        DO 5 J=1,INDNUM-1
          IREC=IREC+LENGTHIND(J)
  5     CONTINUE
      ENDIF
      IF(INDNUM.LE.NUMIND) THEN
         READ(B1ICUR(INDNUM,INDREG),992)
     1   INDMAX,MPASTP,PHDRAT,INDDIR,
     1   LENGTHIND,IDVAL,
     2   BBCSC,BBELAS,BBEMPL,IFSMAX,IFSLOC,
     3   INDNAME,INDSTEPNAME,
     4   IFSBYP,IFSLOCBY,BYBSCSC,GINTER,
     5   GSTEAM,GENEQPHTRT,
     6   CUMOUT88,A8
         IF(A8.NE.B1ICUR(INDNUM,INDREG)(NUMB1I-7:NUMB1I))THEN
           WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. RDBIN'
           WRITE(6,'(1X,5A)') 'B1ICUR"',A8,'" DOESN''T MATCH "',
     1     B1ICUR(INDNUM,INDREG)(NUMB1I-7:NUMB1I),'"'
         ENDIF
       ELSE
         WRITE(6,*) 'NUMIND DIM TOO SMALL IN SUBR. RDBIN:',
     1   NUMIND,INDNUM
       ENDIF
C****
C    READ PROCESS CONTROL VARIABLES AND COEFFICIENTS THAT DON'T
C    CHANGE FROM YEAR TO YEAR BUT DO CHANGE FROM INDUSTRY TO INDUSTRY
C    FROM THE SECOND INDBIN1 BUFFER.  THE SECOND PART INCLUDES PROCESS
C    SPECIFIC INFORMATION FOR THE INDUSTRY.
C****

      DO 50 IS=1,MPASTP
        IREC=IREC+1
        IP=IREC-INDNUM
        IF(IP.LE.NUMPROC.AND.IP.GE.1) THEN
          READ(B1PCUR(IP,INDREG),992)
     1    INDDIR,NTMAXZ,IFMAXZ,IPASTPZ,
     1    IFLOCZ,ITYPEZ,BCSCZ,BELASZ,IFBYPZ,IFLOCBYZ,BYPCSCZ,EINTERZ,
     1    A8
          IF(A8.NE.B1PCUR(IP,INDREG)(NUMB1P-7:NUMB1P))THEN
            WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. RDBIN'
            WRITE(6,'(1X,5A)') 'B1PCUR"',A8,'" DOESN''T MATCH "',
     1      B1PCUR(IP,INDREG)(NUMB1P-7:NUMB1P),'"'
          ENDIF
          ELSE
            WRITE(6,*) 'NUMPROC DIM TOO SMALL IN SUBR. RDBIN:',
     1      NUMPROC,IP
        ENDIF

        NTMAX(IS)=NTMAXZ
        IFMAX(IS)=IFMAXZ
        IFBYP(IS)=IFBYPZ

        DO 45 IT=1,5
          IPASTP(IS,IT)=IPASTPZ(IT)
   45   CONTINUE

        DO 49 IF=1,15
          IFLOC(IF,IS)=IFLOCZ(IF)
          ITYPE(IF,IS)=ITYPEZ(IF)
          DO 47 IT=1,3
            BCSC(IT,IF,IS)=BCSCZ(IT,IF)
            EINTER(IT,IF,IS)=EINTERZ(IT,IF)
            DO 46 JF=1,11
              BELAS(IT,IF,IS,JF)=BELASZ(IT,IF,JF)
   46       CONTINUE
   47     CONTINUE
   49   CONTINUE
        DO 48 IF=1,5
          IFLOCBY(IF,IS)=IFLOCBYZ(IF)
          DO 485 IT=1,3
            BYPCSC(IT,IF,IS)=BYPCSCZ(IT,IF)
  485     CONTINUE
   48   CONTINUE
   50 CONTINUE

C****
C  READ THE VARIABLES THAT CONTAIN RESULTS THAT CHANGE FROM YEAR
C  TO YEAR AND FROM INDUSTRY TO INDUSTRY FROM THE INDBIN2 BUFFER.
C****

C****
C    THIS PART READS NON-PROCESS SPECIFIC INFORMATION.
C****

      IY=IYR-1990-1
      LENGTHSUM=0
      DO 125 J=1,INDMAX
        LENGTHSUM=LENGTHSUM+LENGTHIND(J)
125   CONTINUE
      IREC=(IY)*LENGTHSUM
      IF(INDNUM.EQ.1) THEN
        IREC=IREC+1
      ELSE
        DO 130 J=1,INDNUM-1
          IREC=IREC+LENGTHIND(J)
130     CONTINUE
        IREC=IREC+1
      ENDIF
      IF(INDNUM.LE.NUMIND) THEN
         READ(B2ILAG(INDNUM,INDREG),992)
     2   INDDIR,ENPMQTY,ENPIQTY,ENPRQTY,REGPRODX,REGEMPLX,REGPRCX,
     3   REGPRODVX,
     3   ENBINT,ENBQTY,ENSINT,ENSQTY,BSSHRLAG,STEMCUR,
     4   ELGEN,
     4   ELOWN,ELSALE,GENFUEL,BYSINT,QTYMTEMP,QTYITEMP,
     4   QTYRTEMP,BYPBSCM,BYPBSCI,BYPBSCR,A8
         IF(A8.NE.B2ILAG(INDNUM,INDREG)(NUMB2I-7:NUMB2I))THEN
           WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. RDBIN'
           WRITE(6,'(1X,5A)') 'B2ILAG"',A8,'" DOESN''T MATCH "',
     1     B2ILAG(INDNUM,INDREG)(NUMB2I-7:NUMB2I),'"'
         ENDIF
      ELSE
         WRITE(6,*) 'NUMIND DIM TOO SMALL IN SUBR. RDBIN:',
     1   NUMIND,INDNUM
      ENDIF

      DO J=1,50
        PRCXLAG(J)=REGPRCX(J)
      ENDDO
      DO J=1,15
        PRODVXLAG(J)=REGPRODVX(J)
        PRODXLAG(J)=REGPRODX(J)
        EMPLXLAG(J)=REGEMPLX(J)
      ENDDO

C****
C    THIS PART READS PROCESS SPECIFIC INFORMATION.
C****

      DO 200 IS=1,MPASTP
        IREC=IREC+1
        IP=IREC-(IY*LENGTHSUM)-INDNUM
        IF(IP.LE.NUMPROC.AND.IP.GE.1) THEN
          READ(B2PLAG(IP,INDREG),992)
     1    INDDIR,ISZ,PRODRTRZ,PRODCURZ,PRODLAGZ,PRODZEROZ,
     1    PRODFLWZ,CSCCURZ,CSCLAGZ,PRCCURZ,PRCLAGZ,ENPINTZ,ENPQTYZ,
     3    BYPCSCCURZ,BYPCSCLAGZ,BYPINTZ,BYPQTYZ,IDLCAPZ,A8
          IF(A8.NE.B2PLAG(IP,INDREG)(NUMB2P-7:NUMB2P))THEN
            WRITE(6,*) ' BAD BUFFER LENGTH IN SUBR. RDBIN'
            WRITE(6,'(1X,5A)') 'B2PLAG"',A8,'" DOESN''T MATCH "',
     1      B2PLAG(IP,INDREG)(NUMB2P-7:NUMB2P),'"'
          ENDIF
        ELSE
          WRITE(6,*) 'NUMPROC DIM TOO SMALL IN SUBR. RDBIN:',
     1    NUMPROC,IP
        ENDIF
        PRODRETR(IS)=PRODRTRZ
        IDLCAP(IS)=IDLCAPZ(IS)
        DO 101 IV=1,4
          PRODCUR(IV,IS)=PRODCURZ(IV)
          PRODLAG(IV,IS)=PRODLAGZ(IV)
          PRODZERO(IV,IS)=PRODZEROZ(IV)
  101   CONTINUE
        DO 103 IT=1,5
          DO ITA=1,2
            PRODFLOW(ITA,IS,IT)=PRODFLWZ(ITA,IT)
          ENDDO
  103   CONTINUE
        DO 109 IF=1,15
          DO 107 IV=1,3
            CSCCUR(IV,IF,IS)=CSCCURZ(IV,IF)
            CSCLAG(IV,IF,IS)=CSCLAGZ(IV,IF)
            PRCCUR(IV,IF,IS)=PRCCURZ(IV,IF)
            PRCLAG(IV,IF,IS)=PRCLAGZ(IV,IF)
            ENPINTLAG(IV,IF,IS)=ENPINTZ(IV,IF)
            ENPINT(IV,IF,IS)=ENPINTZ(IV,IF)
            ENPQTY(IV,IF,IS)=ENPQTYZ(IV,IF)
  107     CONTINUE
          ENPQTY(4,IF,IS)=ENPQTYZ(4,IF)
  109   CONTINUE
        DO 111 IF=1,5
          DO 110 IV=1,3
            BYPCSCCUR(IV,IF,IS)=BYPCSCCURZ(IV,IF)
            BYPCSCLAG(IV,IF,IS)=BYPCSCLAGZ(IV,IF)
            BYPINTLAG(IV,IF,IS)=BYPINTZ(IV,IF)
            BYPINT(IV,IF,IS)=BYPINTZ(IV,IF)
  110     CONTINUE
  111   CONTINUE
        DO IF=1,6
          DO IV=1,4
            BYPQTY(IV,IF,IS)=BYPQTYZ(IV,IF)
          ENDDO
        ENDDO
C****
C  INITIALIZE AND ACCUMULATE CUMULATIVE VARIABLES.
C****
        IF(FSTITER.EQ.1.AND.IY.EQ.0) THEN
C  FIRST TIME THRU (FIRST ITERATION, SECOND YEAR), JUST INITIALIZE
C  WITH LAST' YEARS VALUES
          DO IV=1,4
            ACUMOUT(IV,IP,INDREG)=PRODCURZ(IV)+CUMOUT88
            ACUMPROD(IV,IP,INDREG)=PRODCURZ(IV)
          ENDDO
          DO IF=1,15
            ASUMPINT(IF,IP,INDREG)=ENPINTZ(3,IF)*PRODCURZ(3)
          ENDDO
        ELSEIF(FSTITER.EQ.1.AND.IY.GT.0) THEN
C ON SUBSEQUENT YEARS (FIRST ITERATION ONLY), ACCUMULATE LAST YEAR'S
C VALUES
C ***NOTE: SEEMS ODD TO BE ADDING IN "CUMOUT88" EVERY YEAR. SHOULDN'T
C THIS BE A ONE-TIME THING?
          DO IV=1,4
            ACUMOUT(IV,IP,INDREG)=ACUMOUT(IV,IP,INDREG)+
     2         PRODCURZ(IV)+CUMOUT88
            ACUMPROD(IV,IP,INDREG)=ACUMPROD(IV,IP,INDREG)+PRODCURZ(IV)
          ENDDO
          DO IF=1,15
            ASUMPINT(IF,IP,INDREG)=ASUMPINT(IF,IP,INDREG)+
     2         ENPINTZ(3,IF)*PRODCURZ(3)
          ENDDO
        ENDIF
C ON ALL YEARS, EVERY ITERATION, COPY INTO WORKING ARRAYS
        DO IV=1,4
          CUMOUT(IV,IS)=ACUMOUT(IV,IP,INDREG)
          CUMPROD(IV,IS)=ACUMPROD(IV,IP,INDREG)
        ENDDO
        DO IF=1,15
          SUMPINT(IF,IS)=ASUMPINT(IF,IP,INDREG)
        ENDDO
  200 CONTINUE

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'RDBIN')
992   FORMAT(255A,255A,255A,255A,255A,255A,255A)

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  IF NOT THE FIRST YEAR, THE
C  MODEL CALCULATIONS ARE DIRECTED FROM THIS SUBROUTINE.
C****

      SUBROUTINE MODCAL
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER I,TLOGFLG,COUNT
      INTEGER INTSVE(7)
      INTEGER NONMFG(8)
      INTEGER IS,IF,IFX
      DATA INTSVE/7,8,9,10,11,12,13/
      DATA NONMFG/0,0,1,2,3,4,5,6/
C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE ENERGY CONSUMPTION IN THE PA COMPONENT.
C****

C****
C    DETERMINE PRODUCTION FLOWS FOR EACH PROCESS/ASSEMBLY STEP.
C****

      CALL CALPROD


c *** call the nonmanufacturing industries ****
       if(inddir.le.6) then           
           call calcsc
           call calprc
        endif

C****
C    CALCULATE THIS YEAR'S UECS BASED ON TRANSLOG METHODOLOGY
C****
      IF(INDDIR.EQ.14.OR.INDDIR.EQ.15) THEN
         DO IS = 1,MPASTP
          DO IF = 1,IFMAX(IS)
            IFX = IFLOC(IF,IS)
            IF(IFX.NE.1.and.IFX.NE.3.and.IFX.NE.7.and.
     1       IFX.NE.10.and.IFX.NE.11.and.IFX.NE.12) THEN
               CALL CALCSC1(IF,IS)
               CALL CALPRC1(IF,IS)
            ENDIF
          ENDDO
         ENDDO
          IF(PRODCUR(4,1).GT.0.001) 
     1    CALL CALTLOG
        ENDIF
C****
C CALCULATE THIS YEAR'S UECS BASED ON TPC/CSC PARAMETERS IN THE
C PA COMPONENT AND PRICE PARAMETERS
C****
            IF (INDDIR.GE.7.AND.INDDIR.LE.13) THEN
                CALL CALCSC
                CALL CALPRC
            ENDIF                     

C****
C    ADD UP ENERGY CONSUMPTION OVER THE PROCESS/ASSEMBLY STEPS.
C****

      CALL CALPATOT

C****
C  DETERMINE BYPRODUCT FUEL PRODUCED IN THE PA STEPS.
C****

      CALL CALBYPROD

C****
C  CALCULATE ENERGY CONSUMPTION IN BUILDINGS.
C****


C****
C    DETERMINE THIS YEAR'S EFFICIENCIES FOR LIGHTING AND HVAC.
C****

C     CALL CALBLD

C****
C    ADD UP TOTAL BUILDING ENERGY CONSUMPTION.
C****

      CALL CALBTOT

C****
C  CALCULATE ENERGY CONSUMPTION IN BOILER/STEAM/COGEN.
C****

C****
C    CALCULATE ELECTRICITY GENERATION.
C****

      CALL CALGEN

C****
C    CALCULATE THIS YEAR'S FUEL SHARES AND INTENSITIES.
C****
      CALL CALBSC
C****
C    ADD UP TOTAL ENERGY CONSUMPTION IN THE BSC COMPONENT.
C****

      CALL CALSTOT

C****
C  CALCULATE OVERALL INDUSTRY TOTALS.
C****

      CALL INDTOTAL

C****
C  CALCULATE OVERALL INDUSTRY NATIONAL TOTALS.
C****

      IF(INDREG.EQ.4) THEN

        CALL NATTOTAL

C****
C  FILL IN VALUES FOR NEMS REPORT WRITER VARIABLES.
C****

        CALL CONTAB

      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'MODCAL')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE DETERMINES THE PRODUCTION FLOWS FOR THE
C  PROCESS AND ASSEMBLY COMPONENT.
C
C     Retirement of capacity is implemented.
C     Production of Pre-1991, Post-91, and New Capacity is tracked. 
C     New Capacity requirements are calculated that meet final demand
c     changes and retirements.  New Capacity is determined in a product
c     flow balance equation that insures downstep requirements are met
c     by a mix of surviving capacity and new capacity.  
C
      SUBROUTINE CALPROD
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(APQ)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
      INCLUDE(INDBENCH)

      INTEGER IS,IV,IT,IP,I,J,IC
      INTEGER IDBGPRT                ! Local Debug Printout Switch for Process industries 
      REAL PRODX90(15,4)/60*0./     ! Holds 1990 version of PRODX (Ind. Production) by industry and region
      REAL PRODXMID/0./              ! Holds Change in PRODX since 1990
      REAL PRODXNEW/0./              ! Holds Change in PRODX from prior year
      INTEGER MAXSTPS
      PARAMETER (MAXSTPS=8)
      REAL PRODSAV(4,MAXSTPS)
      REAL ALPHA(7)
      REAL MCPRICE(4) 
      REAL DELTA
      REAL retsave
      INTEGER IY,IR,CASE

C Product Flow Balance Coefficients. Multiplied by PRODCUR to determine
C new capacity additions that will balance downstep requirements against
c existing capacity, such that new capacity is added in proportion to
c rates specified in the PRODFLOW(NEW, , )  array 
      REAL PFold(MAXSTPS,0:MAXSTPS),SUMOLD  ! Product Flow Balance Coefficients for PRODCUR-Old
      REAL PFmid(MAXSTPS,0:MAXSTPS),SUMMID  ! Product Flow Balance Coefficients for PRODCUR-MID
      REAL PFnew(MAXSTPS,0:MAXSTPS),SUMNEW  ! Product Flow Balance Coefficients for PRODCUR-NEW
      REAL JOINTSHR(MAXSTPS,2)              ! Steps Shares of Joint Capacity Requirements
                                            !    1st set for Idling, 2nd set used for Adding
      REAL JOINTNEED                        ! Temporarily holds Joint Capacity Requirements
      REAL IDLED_OLD,IDLED_MID
      INTEGER*2 OLD,MID,NEW,TOT ,DOWN_STEP, ! Constants Used to Refer to Subscripts by Name
     1 OLD_RATE,NEW_RATE                    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD=1,MID=2,NEW=3,TOT=4)    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD_RATE=1,NEW_RATE=2)      ! Constants Used to Refer to Subscripts by Name

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

      DATA ALPHA/1.0,2.5,3.0,3.5,4.0,4.5,5.0/
c     DATA ALPHA/1.0,4.0,4.5,5.5,6.5,7.5,8.5/

      CASE=1
      DELTA = 0.0
      IY = IYR - 1989
      IR = INDREG
 
c ***  save the coke oven base retirement rate in first year ***
c ***  the subroutine is called                              ***
c ***  the following lines change retirement rate based on   ***
c ***  the change in met coal price                          ***

      if(curiyr.eq.2.and.inddir.eq.12) retsave = prodretr(8)

      MCPRICE(IR) = PMCIN(IR,IY)
      IF(IYR.EQ.1997)PRCX97(IR,2) = MCPRICE(IR)
        
      IF(IYR.GT.1997) THEN
       DELTA = ((MCPRICE(IR) - PRCX97(IR,2))/PRCX97(IR,2))*100
      ENDIF

      IF(DELTA.LT.25.0) THEN
         CASE = 1
      ELSEIF(DELTA.GE.25.AND.DELTA.LT.100.0) THEN
         CASE = 2
      ELSEIF(DELTA.GE.100.0.AND.DELTA.LT.150.0) THEN
         CASE = 3
      ELSEIF(DELTA.GE.150.0.AND.DELTA.LT.200.0) THEN
         CASE = 4
      ELSEIF(DELTA.GE.200.0.AND.DELTA.LT.250.0) THEN
         CASE = 5
      ELSEIF(DELTA.GE.250.0.AND.DELTA.LT.300.0) THEN
         CASE = 6
      ELSEIF(DELTA.GT.300.0) THEN
         CASE = 7
      ENDIF
      
C   Adjust retirement rate on coke oven according to carbon tax price
C   of met coal

      IF(INDDIR.EQ.12) PRODRETR(8) = ALPHA(CASE)*retsave

C   If this is a RETIREMENT SENSITIVITY CASE,
C
C   If this is a RETIREMENT SENSITIVITY CASE,
C   Adjust Retirement Rates by sensistivity multiplier
C
       IF(IRETIRE.EQ.1.AND.IYR.EQ.1996) THEN
         DO IS = 1,MPASTP

C ***** LBNL RCR EXPANDING RETIREMENT RATE -- SUBSECTOR SPECIFIC VALUES *****
          WRITE(*,*)'***** LBNL RCR RETIRE-- ',CURIYR,CURITR,INDDIR

          IF (INDDIR.EQ.7) THEN
             PRODRETR(IS)=MIN(0.9, 4.0 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.8) THEN
             PRODRETR(IS)=MIN(0.9, 2.5 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.9) THEN
             PRODRETR(IS)=MIN(0.9, 2.2 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.10) THEN  
             PRODRETR(IS)=MIN(0.9, 2.0 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.11) THEN
             PRODRETR(IS)=MIN(0.9, 2.0 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.12) THEN
             PRODRETR(IS)=MIN(0.9, 2.0 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.13) THEN
             PRODRETR(IS)=MIN(0.9, 3.5 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.14) THEN
             PRODRETR(IS)=MIN(0.9, 2.0 *PRODRETR(IS))
          ELSE IF (INDDIR.EQ.15) THEN
             PRODRETR(IS)=MIN(0.9, 2.0 *PRODRETR(IS))
          ELSE
             PRODRETR(IS)=MIN(0.9,RETRATE*PRODRETR(IS))
          ENDIF
C ***** RCR LBNL END *****

         ENDDO
       ENDIF

C    SAVE PRODUCTION FROM THE PREVIOUS YEAR.
C    Also, RETAIN 1991 PRODUCTION FOR CONSTRUCTION AND CHEMICAL
C    INDUSTRIES IN ARRAY PRODZERO.  PRODZERO WILL BE USED IN
C    PLACE OF PRODCUR IN COMPUTING ASPHALT AND CHEMICAL FEEDSTOCKS

      DO IS=1,MPASTP                                   ! For each process step
        DO IV=1,4                                      ! For each Vintage (old, mid, new, and total)
          PRODLAG(IV,IS)=PRODCUR(IV,IS)                 
          IF(IYR.EQ.1991.AND.(INDDIR.EQ.6.OR.INDDIR.EQ.9)) THEN
            PRODZERO(IV,IS)=PRODCUR(IV,IS)
          ENDIF

        ENDDO
      ENDDO

C    Restore any capacity that was idled last year.
C    For Energy Intensive Industries (INDDIR>6),
C    retire the OLD and MIDDLE Production Capacity

      DO IS=1,MPASTP
        PRODCUR(MID,IS)=PRODCUR(MID,IS)+PRODCUR(NEW,IS)   ! Put last year's NEW into this year's MID 
        PRODCUR(OLD,IS)=PRODCUR(OLD,IS)+IDLCAP(IS)        ! Add back any Idled Capacity from Last Year
        IDLCAP(IS)=0.                                     ! Initialize Idle Capacity
        PRODCUR(NEW,IS)=0.0                               ! Initialize New  Capacity

        IF(INDDIR.GT.6) THEN
          PRODCUR(OLD,IS)=PRODCUR(OLD,IS)*(1.0-PRODRETR(IS))
          PRODCUR(MID,IS)=PRODCUR(MID,IS)*(1.0-PRODRETR(IS))

        ENDIF
        PRODCUR(TOT,IS)=PRODCUR(OLD,IS)+PRODCUR(MID,IS)
      ENDDO
   
C  Assign the eXogenouse PRODuction requirements (PRODX), possibly
C  adjusting the units (dollars or tons) based in industry option IDVAL. 
C  For PHYSICAL UNITS (tons) (IDVAL=1), Convert units using
C  the fixed relationship between dollar value and physical value (PHDRAT).
C  NOTE: The proper pronunciation of PHDRAT is FUD'-RAT.

      IF(IDVAL.EQ.1.AND.IYR.EQ.1991) THEN
        PHDRAT=TONOUT(INDDIR,INDREG)/PRODVX(INDDIR,INDREG) !RATIO OF PHY TO DOLLAR VALUE
      ENDIF

      IF(IDVAL.EQ.1) THEN
        PRODX(INDDIR,INDREG)=PHDRAT*PRODVX(INDDIR,INDREG)
      ELSEIF(IDVAL.EQ.2) THEN
        PRODX(INDDIR,INDREG)=PRODVX(INDDIR,INDREG)
      ENDIF
C
C    Break exogenous production out into a 1990 component, Post-1991 component,
C    and a new component.  This is for compatibility with the process step
C    vintaging.
C
      IF(IYR.EQ.1991) PRODX90(INDDIR,INDREG)=PRODXLAG(INDDIR)
      PRODXMID=PRODXLAG(INDDIR)-PRODX90(INDDIR,INDREG)
      PRODXNEW=PRODX(INDDIR,INDREG)-PRODXLAG(INDDIR)

C     Fill Coefficients of the Product FLow Balance Equations.  
C     (Must be done here, after retirement and PRODX have taken
C      place)

      CALL BALCOEFF(PFold,PFnew,PFmid,JOINTSHR,IDBGPRT)

      IF(IDBGPRT.EQ.1) THEN
        write(6,*) 'PRODXLAG(INDDIR)=',PRODXLAG(INDDIR)
        write(6,*) 'PRODX(INDDIR,INDREG)=',PRODX(inddir,indreg)
        write(6,*) 'PRODXNEW=',prodxnew
        write(6,*) 'PRODXMID=',prodxmid
        write(6,*) 'PRODX90 =',prodx90(inddir,indreg)
      endif

      IF(IDBGPRT.EQ.1) THEN
        write(6,*) ' PRODCUR, After retirement calcs'
        call prodout
      ENDIF


C     Determine New Production Flows at each process step such that:
C     1) downstep requirements are met, 
c     2) retirements of capacity are replaced, and 
C     3) new capacity is added in proportion to the production flow
C        rate assumptions (or old capacity is idled in proportion
C        to existing capacity).
c     This balance is achieved for each set of steps that meet
c     common downsteps.  The coefficients of the balance are
c     determined by grouping JOINT steps and calculating the
c     new capacity shares of the steps relative to the total.

c     IF(INDDIR.EQ.12) THEN
c       DO IS=1,MPASTP
c       DO IV=1,4
c         PRODSAV(IV,IS)=PRODCUR(IV,IS)
c       ENDDO
c       ENDDO        

c       CALL INDSTEEL
c       IF(IDBGPRT.EQ.1) THEN
c         WRITE(6,*) ' PRODCUR after INDSTEEL '  
c         CALL PRODOUT
c       ENDIF  
c       DO IS=1,MPASTP
c         IDLCAP(IS)=0.
c         DO IV=1,4
c           PRODCUR(IV,IS)=PRODSAV(IV,IS)
c         ENDDO
c       ENDDO
c     ENDIF
      
      DO IS=1,MPASTP                                              ! For each process step
        PRODCUR(TOT,IS)=0.0
        PRODCUR(NEW,IS)=0.0

C   Solve Product Flow Balance Equation in 3 parts (old, mid and new).
C   For industries with uniform retirement rates for all process steps,
C   SUMOLD and SUMMID yield 0.  

        SUMOLD=PRODX90(INDDIR,INDREG)*PFold(IS,0)
        SUMMID=PRODXMID              *PFmid(IS,0)
        SUMNEW=PRODXNEW              *PFnew(IS,0)
        DO IT=1,MPASTP
          SUMOLD=SUMOLD+PRODCUR(OLD,IT)*PFold(IS,IT)
          SUMMID=SUMMID+PRODCUR(MID,IT)*PFmid(IS,IT)
          SUMNEW=SUMNEW+PRODCUR(NEW,IT)*PFnew(IS,IT)
        ENDDO

C   Apply New Capacity Share to obtain this step's share
c   of JOINT step capacity.  When negative, revise with
C   shares used when selecting capacity to idle.

        JOINTNEED=-1*(SUMOLD+SUMMID+SUMNEW)
        IF(JOINTNEED.GE.0.0) THEN
          PRODCUR(NEW,IS)=JOINTNEED*JOINTSHR(IS,2)  ! Add using NEW Capacity Shares
        ELSE
          PRODCUR(NEW,IS)=JOINTNEED*JOINTSHR(IS,1)  ! Idle using existing Capacity Shares
        ENDIF
      ENDDO
C
C   Treat a negative result for new capacity as a temporary
C   idling of capacity.
C
      DO IS=1,MPASTP
        IF(PRODCUR(NEW,IS).LT.0.) THEN
          IDLCAP(IS)=-1.*PRODCUR(NEW,IS)
          PRODCUR(NEW,IS)=0.
        ENDIF
        IDLED_OLD = MIN( PRODCUR(OLD,IS) , IDLCAP(IS))          ! Idle as much OLD capacity as possible
        IDLED_MID = IDLCAP(IS) - IDLED_OLD                      ! Idle the rest from MID capacity
            
        PRODCUR(OLD,IS) = PRODCUR(OLD,IS) - IDLED_OLD           ! Amount of Production from Old Capacity
        PRODCUR(MID,IS) = PRODCUR(MID,IS) - IDLED_MID           ! Amount of Production from MID Capacit
        PRODCUR(TOT,IS)=PRODCUR(OLD,IS)+PRODCUR(MID,IS)+PRODCUR(NEW,IS)
      ENDDO

  991 FORMAT(3X,'CALPROD')
      IF(IDBGPRT.EQ.1) THEN
        write(6,*) ' PRODCUR, After All calcs'
        call prodout
      ENDIF
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C      This routine determines the Product FLow Balance
C      Coefficients used by 
C 
      SUBROUTINE BALCOEFF(PFold,PFnew,PFmid,JOINTSHR,IDBGPRT)
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
      INTEGER IS,IT,I,IC,IDBGPRT
      INTEGER MAXSTPS
      PARAMETER (MAXSTPS=8)

C Product Flow Balance Coefficients. Multiplied by PRODCUR to determine
C new capacity additions that will balance downstep requirements against
c existing capacity, such that new capacity is added in proportion to
c rates specified in PRODFLOW(NEW, , ) 
      REAL PFold(MAXSTPS,0:MAXSTPS),SUMOLD  ! Product Flow Balance Coefficients for PRODCUR-Old
      REAL PFmid(MAXSTPS,0:MAXSTPS),SUMMID  ! Product Flow Balance Coefficients for PRODCUR-MID
      REAL PFnew(MAXSTPS,0:MAXSTPS),SUMNEW  ! Product Flow Balance Coefficients for PRODCUR-NEW
      REAL JOINTSHR(MAXSTPS,2)              ! Steps Shares of Joint Capacity Requirements
                                            !    1st set for idling, 2nd set used for Adding 
      REAL SUMDENI,SUMDENA                  ! Sum of terms in denominator of New Capacity Share Factor
      REAL SUMNUMI,SUMNUMA                  ! Sum of terms in numerator   of New Capacity Share Factor
      REAL PFidle(MAXSTPS,MAXSTPS)          ! Prodflow recomputed using PRODCUR(TOT,,) to obtain IDLING shares
      REAL SUMDOWN,DOWNFLOW                 ! Hold downflows recomputed for current year with PRODFLOW
      REAL BALRATE(0:MAXSTPS,0:MAXSTPS,2)   ! BALANCE Flow RATES -- similar to PRODFLOW but multiplied out 
      INTEGER*2 OLD,MID,NEW,TOT ,DOWN_STEP, ! Constants Used to Refer to Subscripts by Name
     1 OLD_RATE,NEW_RATE                    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD=1,MID=2,NEW=3,TOT=4)    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD_RATE=1,NEW_RATE=2)      ! Constants Used to Refer to Subscripts by Name

      IDBGPRT=0                             ! Initialize Local Debug Print.
      IF(PRTDBGI.GT.1.AND.                  ! To use, Set Runtime Option IPRTDBGI=2.
     1   MPASTP .GT.1.AND.                  ! Prints for Paper, Steel, Chem, Glass, Cement
     1   INDREG .LT.5) THEN                 ! All regions
C     1   INDREG.EQ.1) THEN                 ! First region is enough.
        IDBGPRT=1                                           
        WRITE(6,*) ' CALPROD Industry: ',INDNAME
        WRITE(6,*) '           Region: ',INDREG
      ENDIF

C ZERO Product Flow Balance COEFFICIENTS
      IF(MPASTP.GT.MAXSTPS) THEN
        WRITE(6,*) ' The dimensions of the PF--- variables in ',
     1  ' BALCOEFF are too small for industry ',INDDIR
        WRITE(6,*) ' MPASTP=',MPASTP,', MAXSTPS=',MAXSTPS
      ENDIF
      DO IS=1,MAXSTPS
        JOINTSHR(IS,1)=0.
        JOINTSHR(IS,2)=0.
        DO IT=0,MAXSTPS
          PFold(IS,IT)=0.
          PFnew(IS,IT)=0.
          PFmid(IS,IT)=0.
          BALRATE(IS,IT,1)=0.
          BALRATE(IS,IT,2)=0.
        ENDDO
      ENDDO

C   Recompute this year's flow rates for combined old and mid capacity.  This
C   set of flow rates will be used to determine the idling shares--ie, the
C   capacity that is temporarily idled when production drops faster than
C   retirement.

      DO IS=1,MPASTP
        SUMDOWN=0.                                               ! Sum of flows to downsteps
        DO IT=1,NTMAX(IS)
          PFidle(IS,IT)=0.
          DOWN_STEP=IPASTP(IS,IT)
          IF(DOWN_STEP.EQ.0) THEN
            DOWNFLOW=PRODX(INDDIR,INDREG)
          ELSE
            DOWNFLOW=PRODCUR(TOT,DOWN_STEP)
          ENDIF
          SUMDOWN=SUMDOWN+DOWNFLOW
        ENDDO
C    By convention, the rates are computed such that all downsteps get the
C    same rate.
        DO IT=1,NTMAX(IS)
          IF(SUMDOWN.GT.0.0) THEN
            PFidle(IS,IT)=PRODCUR(TOT,IS)/SUMDOWN
          ENDIF
        ENDDO
      ENDDO

C    Fill BALRATE from PRODFLOW(NEW_RATE, , ) to express flow rates as
c    functions of final demand rather than as functions of the immediate
c    downstep.  BALRATE used to compute capacity addition shares (JOINTSHR) of
c    steps that JOINTly meet downstep requirements.  Using BALRATE, 
c    instead of PRODFLOW, for JOINT capacity shares makes a difference for the
c    Paper Industry, where pulping processes flow to bleaching or to
c    paper making directly.  (Don't even try to understand--just accept it. )

      BALRATE(0,0,1)=1.
      BALRATE(0,0,2)=1.
      DO IS=1,MPASTP                                      ! for each process step
        DO IT=1,NTMAX(IS)                                 ! for each downstep
          DOWN_STEP=IPASTP(IS,IT)                

          BALRATE(IS,IT,1)=PFidle(IS,IT)*BALRATE(DOWN_STEP,0,1) 
          BALRATE(IS,0 ,1)=BALRATE(IS,0,1)+BALRATE(IS,IT,1)      ! Used 0 column as sum

          BALRATE(IS,IT,2)=                                      
     1      PRODFLOW(NEW_RATE,IS,IT)*BALRATE(DOWN_STEP,0,2) 
          BALRATE(IS,0,2)=BALRATE(IS,0,2)+BALRATE(IS,IT,2)      ! Used 0 column as sum

        ENDDO
      ENDDO

C    Fill Product Flow Balance Coefficients for OLD, MID, and NEW 
c    capacity.  Go through each process step.  
c    Find JOINT STEPS --ones that have the same DOWN STEPS.  Then 
c    1) Enter a +1 coefficient for JOINT STEPS so as to include
c       their capacity in the JOINT CAPACITY available to
c       meet downstep requirements.
c    2) Accumulate the sum of JOINT STEPS' flowrates (PRODFLOW) 
c       to common DOWN STEPS (and store in SUMNEW, SUMOLD).  
c       For each such downstep, use the 
C       negative of that sum as the common downstep coefficient.  
c       
c    3) Determine JOINTSHR(IS,), the step's relative share of net downstep
c       requirements using BALRATE
c    4) (Affecting only Paper Bleaching) adjust for steps 
c      that are both JOINT steps and DOWN STEPS of other steps 

      DO IS=1,MPASTP                                   ! For each process step
        SUMDENI=0.
        SUMNUMI=0. 
        SUMDENA=0.
        SUMNUMA=0. 
        DO IT=1,NTMAX(IS)                              ! For each Down Step
          DOWN_STEP=IPASTP(IS,IT)                      ! Point to the down step number
          SUMOLD=0.
          SUMNEW=0.
C Find JOINT Steps
          DO I=1,MPASTP 
            DO IC=1,NTMAX(I)
              IF(IPASTP(I,IC).EQ.DOWN_STEP) THEN
                PFold(IS,I)=1.                          ! 1) Mark JOINT step with a +1 coefficient
                PFmid(IS,I)=1.                          ! 1) Mark JOINT step with a +1 coefficient
                SUMOLD=SUMOLD+PRODFLOW(OLD_RATE,I,IC)   ! 2) Accumulate JOINT step flowrates, OLD 
                SUMNEW=SUMNEW+PRODFLOW(NEW_RATE,I,IC)   ! 2) Accumulate JOINT step flowrates, NEW
                SUMDENI=SUMDENI+BALRATE(I,IC,1)         ! 3) Denominator of step share of JOINT capacity,IDLE  
                SUMDENA=SUMDENA+BALRATE(I,IC,2)         ! 3) Denominator of step share of JOINT capacity,ADD  
              ENDIF
            ENDDO
          ENDDO
          PFold(IS,DOWN_STEP)=PFold(IS,DOWN_STEP)+(-1.*SUMOLD)  ! 2) Use sum of JOINT FLOWS for downstep coeff.
          PFmid(IS,DOWN_STEP)=PFmid(IS,DOWN_STEP)+(-1.*SUMNEW)  
          PFnew(IS,DOWN_STEP)=PFnew(IS,DOWN_STEP)+(-1.*SUMNEW)
          SUMNUMI=BALRATE(IS,0,1)                       ! 3) Numerator of step share of JOINT capacity,IDLE
          SUMNUMA=BALRATE(IS,0,2)                       ! 3) Numerator of step share of JOINT capacity,ADD

C    Adjust for any steps that are BOTH JOINT steps and DOWN STEPS 
c    of other steps. Add the "+1" JOINT capacity coefficient to the 
c    negative JOINT DOWNSTEP coefficient that sums the flowrates
          DO I=IS+1,MPASTP
            IF(PFold(IS,I).EQ.1.0) THEN
               DO IC=1,NTMAX(I)
                 IF(IPASTP(I,IC).EQ.IS) THEN
                   PFold(IS,IS)=PFold(IS,IS)-PRODFLOW(OLD_RATE,I,IC)
                   PFmid(IS,IS)=PFmid(IS,IS)-PRODFLOW(NEW_RATE,I,IC)
                 ENDIF
               ENDDO
             ENDIF
          ENDDO
 
        ENDDO                                          ! end of DOWNSTEP Loop

        IF(SUMDENI.GT.0.0)
     1    JOINTSHR(IS,1)=SUMNUMI/SUMDENI               ! 3) Compute step's share of JOINT capacity, IDLE.
        IF(SUMDENA.GT.0.0) 
     1    JOINTSHR(IS,2)=SUMNUMA/SUMDENA               ! 3) Compute step's share of JOINT capacity, ADD.
      ENDDO                                            ! end of STEP loop

      IF(IDBGPRT.EQ.1.AND.CURIYR.EQ.2) THEN
        write(6,'(/1x,a12,i6,8i7)') 'PRODFLOW-old',(i,i=1,mpastp)
        write(6,'(1x,a12,9A7))') '============',
     1 ('======',i=1,mpastp)
        do IS=1,mpastp
            WRITE(6,'(1X,A12,9F7.3)') INDSTEPNAME(IS),
     1    (prodflow(old_rate,IS,I),I=1,ntmax(is))
        enddo
        write(6,'(/1x,a12,i6,8i7)') 'PRODFLOW-new',(i,i=1,mpastp)
        write(6,'(1x,a12,9A7))') '============',
     1 ('======',i=1,mpastp)
        do IS=1,mpastp
          WRITE(6,'(1X,A12,9F7.3)') INDSTEPNAME(IS),
     1    (prodflow(new_rate,IS,I),I=1,ntmax(is))
        enddo
         WRITE(6,*) ' BALANCE RATES IDLE:'
         WRITE(6,'(13x,a10,3(A10,i2))') '  Total ',
     1       ('Down Step',I,I=1,3)
         DO IS=1,MPASTP
           WRITE(6,'(1X,A12,8F10.4)') INDSTEPNAME(IS),
     1     (BALRATE(IS,IT,1),IT=0,NTMAX(IS))
         ENDDO
         WRITE(6,*) ' BALANCE RATES ADD:'
         WRITE(6,'(13x,a10,3(A10,i2))') '  Total ',
     1       ('Down Step',I,I=1,3)
         DO IS=1,MPASTP
           WRITE(6,'(1X,A12,8F10.4)') INDSTEPNAME(IS),
     1     (BALRATE(IS,IT,2),IT=0,NTMAX(IS))
         ENDDO
        WRITE(6,'(/1x,a)') 'JOINTSHR   Idling  Adding' 
        DO IS=1,MPASTP       
          WRITE(6,'(1x,a12,2F8.4)') INDSTEPNAME(IS),
     1    JOINTSHR(IS,1),JOINTSHR(IS,2) 
        ENDDO
        WRITE(6,'(/1X,A12,I6,8I7)') 'PFold ',(I,I=0,MPASTP)
        write(6,'(1x,a12,9A7))') '============',
     1 ('======',i=0,mpastp)

        DO IS=1,MPASTP
          WRITE(6,'(1X,A12,9F7.3)') INDSTEPNAME(IS),
     1    (PFold(IS,I),I=0,MPASTP)
        ENDDO
        WRITE(6,'(/1X,A12,I6,8I7)') 'PFmid ',(I,I=0,MPASTP)
        write(6,'(1x,a12,9A7))') '============',
     1  ('======',i=0,mpastp)
        DO IS=1,MPASTP
          WRITE(6,'(1X,A12,9F7.3)') INDSTEPNAME(IS),
     1    (PFmid(IS,I),I=0,MPASTP)
        ENDDO
        WRITE(6,'(/1X,A12,I6,8I7)') 'PFnew ',(I,I=0,MPASTP)
        write(6,'(1x,a12,9A7))') '============',
     1  ('======',i=0,mpastp)
        DO IS=1,MPASTP
          WRITE(6,'(1X,A12,9F7.3)') INDSTEPNAME(IS),
     1    (PFnew(IS,I),I=0,MPASTP)
        ENDDO
      ENDIF
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   Debug Printing Routine called from CALPROD and BALCOEFF
C
      SUBROUTINE PRODOUT
      implicit none
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      character*12 stepname(30)
      integer is,iv
      character*10 vintage(5)/
     1 '     Idle',
     2 '      Old',
     2 '      Mid',
     1 '      New',
     1 '      Tot'/
      write(6,'(/13x,5a10)') (vintage(iv),iv=1,5)
      do is=1,MPASTP
         stepname(is)=indstepname(is)
         write(6,'(1x,a12,5f10.0)') stepname(is),
     1  idlcap(is),(prodcur(iv,is),iv=1,4)
      enddo
      write(6,*) ' '
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CALPROD routine written especially for STEEL
C
      SUBROUTINE INDSTEEL
      IMPLICIT NONE
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
      INTEGER COLD_RL,HOT_RL,INGOT,CONTIN,BFOH,BFBOF,EAF,COKE
      PARAMETER(COLD_RL=1,HOT_RL=2,INGOT=3,CONTIN=4,BFOH=5,
     1 BFBOF=6,EAF=7,COKE=8)

      REAL PFold,PFmid,PFnew
      REAL DOWN_STEP_REQD,EXISTCAP,JOINTNEW,DENOM
      REAL SUMOLD,SUMMID,SUMNEW    
      REAL IDLED_OLD,IDLED_MID
      INTEGER IS,TYPE
      
      INTEGER*2 OLD,MID,NEW,TOT ,DOWN_STEP, ! Constants Used to Refer to Subscripts by Name
     1 OLD_RATE,NEW_RATE                    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD=1,MID=2,NEW=3,TOT=4)    ! Constants Used to Refer to Subscripts by Name
      PARAMETER(OLD_RATE=1,NEW_RATE=2)      ! Constants Used to Refer to Subscripts by Name
C
      REAL JOINTSHR(8,2)
      
C     Determine New Production Flows at each group of
C     process steps such that 1) downstep requirements are met, 
c     2) retirements of capacity are replaced, and 3) new capacity is
c     added in proportion to the production flow rate assumptions.
c     This balance is achieved for each set of steps that meet
c     common downsteps. Group JOINT steps and calculate the
c     new capacity shares of the steps relative to the JOINT total.
C****
      DO IS=1,MPASTP                                              ! For each process step
        PRODCUR(NEW,IS)=0.0
        JOINTSHR(IS,1)=0.
        JOINTSHR(IS,2)=0.
      ENDDO

C +++ Cold-Rolling and Hot-Rolling--Both flow to 
C +++ eXogenous PRODuction (PRODX) (ie, final demand)
      
      PFold=PRODFLOW(OLD_RATE,COLD_RL,1)+         ! = 1.301 
     1      PRODFLOW(OLD_RATE,HOT_RL ,1)
      PFnew=PRODFLOW(NEW_RATE,COLD_RL,1)+         ! = 1.301
     1      PRODFLOW(NEW_RATE,HOT_RL ,1)

C Shares if need to Idle existing Capacity.  
      JOINTSHR(COLD_RL,1)=PRODCUR(TOT,COLD_RL)/
     1    (PRODCUR(TOT,COLD_RL)+PRODCUR(TOT,HOT_RL))
      JOINTSHR(HOT_RL,1)=PRODCUR(TOT,HOT_RL)/
     1    (PRODCUR(TOT,COLD_RL)+PRODCUR(TOT,HOT_RL))

C Shares if need to Add new Capacity     
      JOINTSHR(COLD_RL,2)=
     1   PRODFLOW(NEW_RATE,COLD_RL,1) /
     1  (PRODFLOW(NEW_RATE,COLD_RL,1)+PRODFLOW(NEW_RATE,HOT_RL,1))
      JOINTSHR(HOT_RL,2)=
     1   PRODFLOW(NEW_RATE,HOT_RL ,1) /
     1  (PRODFLOW(NEW_RATE,COLD_RL,1)+PRODFLOW(NEW_RATE,HOT_RL,1))
         
      DOWN_STEP_REQD=PRODX(INDDIR,INDREG)*PFold

      EXISTCAP=PRODCUR(OLD,COLD_RL)+PRODCUR(MID,COLD_RL)+
     1         PRODCUR(OLD,HOT_RL )+PRODCUR(MID,HOT_RL )

      JOINTNEW=DOWN_STEP_REQD - EXISTCAP
        
      IF(JOINTNEW.LE.0.) TYPE=1   ! Idle
      IF(JOINTNEW.GT.0.) TYPE=2   ! ADD
      PRODCUR(NEW,COLD_RL)=JOINTNEW*JOINTSHR(COLD_RL,TYPE)
      PRODCUR(NEW,HOT_RL )=JOINTNEW*JOINTSHR(HOT_RL ,TYPE)        

C +++ Ingot Casting and Continuous Casting--Both flow to
C +++ Hot Rolling.  All NEW goes to Continuous, none to Ingot.
 
      PFold=PRODFLOW(OLD_RATE,INGOT ,1)+           ! 1.068    
     1      PRODFLOW(OLD_RATE,CONTIN,1)
      PFnew=PRODFLOW(NEW_RATE,INGOT ,1)+           ! 1.068
     1      PRODFLOW(NEW_RATE,CONTIN,1)
    
C Shares if need to Idle existing Capacity.  
      JOINTSHR(INGOT,1)=PRODCUR(TOT,INGOT)/
     1    (PRODCUR(TOT,INGOT)+PRODCUR(TOT,CONTIN))
      JOINTSHR(CONTIN,1)=PRODCUR(TOT,CONTIN)/
     1    (PRODCUR(TOT,INGOT)+PRODCUR(TOT,CONTIN))

C Shares if need to Add new Capacity     
      JOINTSHR(INGOT,2)=
     1   PRODFLOW(NEW_RATE,INGOT ,1) /
     1  (PRODFLOW(NEW_RATE,INGOT ,1)+PRODFLOW(NEW_RATE,CONTIN,1))

      JOINTSHR(CONTIN,2)=
     1   PRODFLOW(NEW_RATE,CONTIN,1) /
     1  (PRODFLOW(NEW_RATE,INGOT ,1)+PRODFLOW(NEW_RATE,CONTIN,1))
  
      SUMOLD=PRODCUR(OLD,HOT_RL)*PFold 
      SUMMID=PRODCUR(MID,HOT_RL)*PFnew
      SUMNEW=PRODCUR(NEW,HOT_RL)*PFnew
     
      DOWN_STEP_REQD=SUMOLD+SUMMID+SUMNEW

      EXISTCAP=PRODCUR(OLD,INGOT )+PRODCUR(MID,INGOT )+
     1         PRODCUR(OLD,CONTIN)+PRODCUR(MID,CONTIN)

      JOINTNEW=DOWN_STEP_REQD - EXISTCAP
        
      IF(JOINTNEW.LE.0.) TYPE=1   ! Idle
      IF(JOINTNEW.GT.0.) TYPE=2   ! ADD
      PRODCUR(NEW,INGOT )=JOINTNEW*JOINTSHR(INGOT ,TYPE)    ! Ingot gets 0%
      PRODCUR(NEW,CONTIN)=JOINTNEW*JOINTSHR(CONTIN,TYPE)    ! Contin gets 100%    

C +++ Blast Furnace/Open Hearth, your Basic Oxygen Furnace, and
C +++ Electric Arc Furnace.  They flow down to Ingot and Continuous
C +++ Casting.  However, there will be no new Open Hearth added.
 
C First combine Flows to INGOT.  Then addin combined flows to CONTINuous Casting
      PFold=PRODFLOW(OLD_RATE,BFOH ,1)+     
     1      PRODFLOW(OLD_RATE,BFBOF,1)+
     1      PRODFLOW(OLD_RATE,EAF  ,1)
      PFnew=PRODFLOW(NEW_RATE,BFOH ,1)+     
     1      PRODFLOW(NEW_RATE,BFBOF,1)+
     1      PRODFLOW(NEW_RATE,EAF  ,1)

      SUMOLD=PRODCUR(OLD,INGOT)*PFold 
      SUMMID=PRODCUR(MID,INGOT)*PFnew
      SUMNEW=PRODCUR(NEW,INGOT)*PFnew

      PFold=PRODFLOW(OLD_RATE,BFOH ,2)+     
     1      PRODFLOW(OLD_RATE,BFBOF,2)+
     1      PRODFLOW(OLD_RATE,EAF  ,2)
      PFnew=PRODFLOW(NEW_RATE,BFOH ,2)+     
     1      PRODFLOW(NEW_RATE,BFBOF,2)+
     1      PRODFLOW(NEW_RATE,EAF  ,2)

      SUMOLD=SUMOLD + PRODCUR(OLD,CONTIN)*PFold 
      SUMMID=SUMMID + PRODCUR(MID,CONTIN)*PFnew
      SUMNEW=SUMNEW + PRODCUR(NEW,CONTIN)*PFnew
 
      DENOM=PRODFLOW(NEW_RATE,BFOH ,1) + PRODFLOW(NEW_RATE,BFOH ,2)+
     1      PRODFLOW(NEW_RATE,BFBOF,1) + PRODFLOW(NEW_RATE,BFBOF,2)+
     1      PRODFLOW(NEW_RATE,EAF  ,1) + PRODFLOW(NEW_RATE,EAF  ,2) 

C Shares if need to Idle existing Capacity.  
      JOINTSHR(BFOH,1)=PRODCUR(TOT,BFOH)/
     1  (PRODCUR(TOT,BFOH)+PRODCUR(TOT,BFBOF)+PRODCUR(TOT,EAF))
      JOINTSHR(BFBOF,1)=PRODCUR(TOT,BFBOF)/
     1  (PRODCUR(TOT,BFOH)+PRODCUR(TOT,BFBOF)+PRODCUR(TOT,EAF))
      JOINTSHR(EAF,1)=PRODCUR(TOT,EAF)/
     1  (PRODCUR(TOT,BFOH)+PRODCUR(TOT,BFBOF)+PRODCUR(TOT,EAF))

C Shares if need to Add new Capacity     
      JOINTSHR(BFOH,2)=
     1  (PRODFLOW(NEW_RATE,BFOH ,1)+PRODFLOW(NEW_RATE,BFOH ,2))/DENOM

      JOINTSHR(BFBOF,2)=
     1  (PRODFLOW(NEW_RATE,BFBOF,1)+PRODFLOW(NEW_RATE,BFBOF,2))/DENOM

       JOINTSHR(EAF,2)=
     1  (PRODFLOW(NEW_RATE,EAF  ,1)+PRODFLOW(NEW_RATE,EAF  ,2))/DENOM

      DOWN_STEP_REQD=SUMOLD+SUMMID+SUMNEW

      EXISTCAP=PRODCUR(OLD,BFOH )+PRODCUR(MID,BFOH)+
     1         PRODCUR(OLD,BFBOF)+PRODCUR(MID,BFBOF)+
     1         PRODCUR(OLD,EAF  )+PRODCUR(MID,EAF)

      JOINTNEW=DOWN_STEP_REQD - EXISTCAP
         
      IF(JOINTNEW.LE.0.) TYPE=1   ! Idle
      IF(JOINTNEW.GT.0.) TYPE=2   ! ADD
      PRODCUR(NEW,BFOH )=JOINTNEW*JOINTSHR(BFOH ,TYPE)  ! 0%
      PRODCUR(NEW,BFBOF)=JOINTNEW*JOINTSHR(BFBOF,TYPE)  ! 40%      
      PRODCUR(NEW,EAF  )=JOINTNEW*JOINTSHR(EAF  ,TYPE)  ! 60%      

C +++ Coke Oven--Flows to Open Hearth and BOF.  However, no new
C +++ Coking capacity is added (coke imported as needed.)
C +++ The calculations are retained in case of idling.  In the
C     west(region4), BFOH is retired quickly and there is
C     no existing BFBOF.  When new BFBOF is added, the existing
c     coke ovens can't use it, even though there sitting there
c     at the retired BFOH plants.

      PFold=PRODFLOW(OLD_RATE,COKE,1)
      PFnew=PRODFLOW(NEW_RATE,COKE,1)

      SUMOLD=PRODCUR(OLD,BFOH)*PFold 
      SUMMID=PRODCUR(MID,BFOH)*PFnew
      SUMNEW=PRODCUR(NEW,BFOH)*PFnew

      PFold=PRODFLOW(OLD_RATE,COKE,2)     
      PFnew=PRODFLOW(NEW_RATE,COKE,2)

      SUMOLD=SUMOLD+PRODCUR(OLD,BFBOF)*PFold 
      SUMMID=SUMMID+PRODCUR(MID,BFBOF)*PFnew
      SUMNEW=SUMNEW+PRODCUR(NEW,BFBOF)*PFnew

C Shares if need to Idle existing Capacity.  
      JOINTSHR(COKE,1)=1.
      JOINTSHR(COKE,2)=PRODFLOW(NEW_RATE,COKE,1)
      
      DOWN_STEP_REQD=SUMOLD+SUMMID+SUMNEW
      
      EXISTCAP=PRODCUR(OLD,COKE)+PRODCUR(MID,COKE)

      JOINTNEW=DOWN_STEP_REQD-EXISTCAP
      IF(JOINTNEW.LE.0.) TYPE=1   ! Idle
      IF(JOINTNEW.GT.0.) TYPE=2   ! ADD
        
      PRODCUR(NEW,COKE)=JOINTNEW*JOINTSHR(COKE,TYPE)  

C
C   Treat a negative result for new capacity as a temporary
C   idling of capacity.
C
      DO IS=1,MPASTP
        IF(PRODCUR(NEW,IS).LT.0.) THEN
          IDLCAP(IS)=-1.*PRODCUR(NEW,IS)
          PRODCUR(NEW,IS)=0.
        ENDIF
        IDLED_OLD = MIN( PRODCUR(OLD,IS) , IDLCAP(IS))          ! Idle as much OLD capacity as possible
        IDLED_MID = IDLCAP(IS) - IDLED_OLD                      ! Idle the rest from MID capacity
            
        PRODCUR(OLD,IS) = PRODCUR(OLD,IS) - IDLED_OLD           ! Amount of Production from Old Capacity
        PRODCUR(MID,IS) = PRODCUR(MID,IS) - IDLED_MID           ! Amount of Production from MID Capacit
        PRODCUR(TOT,IS)=PRODCUR(OLD,IS)+PRODCUR(MID,IS)+PRODCUR(NEW,IS)
      ENDDO

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  CONSERVATION/TECHNOLOGICAL SAVINGS CURVES.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C****
      SUBROUTINE CALCSC
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IS,IF

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE UECS
C****

      DO 20 IS=1,MPASTP
        DO 10 IF=1,IFMAX(IS)

        IF(IWDBG.EQ.1.AND.IOPEN.EQ.1)WRITE(IUNIT1,900)ITYPE(IF,IS)
C****
C    CALCULATE UECS BASED ON EQUATION TYPE 1
c    note that all non-manufacturing has been set to type 1
C****


        if(inddir.le.6) itype(if,is)=1

          IF(ITYPE(IF,IS).EQ.1) THEN
            IF(IWDBG.EQ.1.AND.IOPEN.EQ.1)WRITE(IUNIT1,901)
            CALL CALCSC1(IF,IS)
          ENDIF

C****
C    CALCULATE ENERGY SAVINGS BASED ON EQUATION TYPE 2
C****
          IF(ITYPE(IF,IS).EQ.2) CALL CALCSC2(IF,IS)


C****
C    CALCULATE ENERGY SAVINGS BASED ON EQUATION TYPE 3
C****

          IF(ITYPE(IF,IS).EQ.3) CALL CALCSC3(IF,IS)


 10     CONTINUE
 20   CONTINUE

C****
C  FORMAT STATEMENTS.
C****
  900 FORMAT(3X,'ITYPE',1X,I3)
  901 FORMAT(3X,'ITS A TYPE 1')
  991 FORMAT(3X,'CALCSC')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  CONSERVATION/TECHNOLOGICAL SAVINGS CURVES.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 1 (OLD APPROACH)
C****
      SUBROUTINE CALCSC1(IFUEL,ISTEP)
      IMPLICIT NONE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDALL)

      INTEGER IS,IF,IV,IFUEL,ISTEP
      REAL DELPROD,TPROD

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  FOR EACH PROCESS STEP, AND EACH FUEL,
C  IF THE LAGGED TOTAL THROUGHPUT FOR A PROCESS STEP IS NOT ZERO,
C  THEN CALCULATE THE CSC CURVE ENERGY SAVINGS BASED UPON THE
C  CHANGE IN THE TOTAL PRODUCT.  IF THE LAGGED TOTAL THROUGHPUT IS
C  ZERO, THEN LET THE ENERGY SAVINGS THIS YEAR BE THE SAME AS IT
C  WAS IN THE PREVIOUS YEAR.
C****

c      BCSC(1,IFUEL,ISTEP)=0.0
c      BCSC(3,IFUEL,ISTEP)=0.0

C****
C    CHANGE THIS TO MAKE ABSOLUTELY CERTAIN THE UEC
C    DOES NOT CHANGE. IGNORE NEXT COMMENT FOR NOW
C    CALCULATE ENERGY SAVINGS FOR OLD VINTAGE.
C****
        CSCCUR(1,IFUEL,ISTEP)=CSCLAG(1,IFUEL,ISTEP)

C****
C    CHANGE THIS TO MAKE ABSOLUTELY CERTAIN THE UEC
C    DOES NOT CHANGE. 
C    CALCULATE ENERGY SAVINGS FOR NEW VINTAGE.
C****

        CSCCUR(3,IFUEL,ISTEP)=CSCLAG(3,IFUEL,ISTEP)

C****
C    CHANGE THIS TO MAKE ABSOLUTELY CERTAIN THE UEC
C    DOES NOT CHANGE. 
C****

        CSCCUR(2,IFUEL,ISTEP)=CSCLAG(2,IFUEL,ISTEP)

C****
C    CALCULATE UECS.
C****


      DO 70 IV=1,3
        IF(CSCLAG(IV,IFUEL,ISTEP).NE.0.0) THEN
         ENPINT(IV,IFUEL,ISTEP)=ENPINTLAG(IV,IFUEL,ISTEP)
        CSCLAG(IV,IFUEL,ISTEP)=CSCCUR(IV,IFUEL,ISTEP)
       ENDIF
          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1)THEN
            WRITE(IUNIT1,802) IV,IFUEL,ISTEP,ENPINT(IV,IFUEL,ISTEP)
            WRITE(IUNIT1,803)CSCLAG(IV,IFUEL,ISTEP)
        ENDIF
   70 CONTINUE

C  Do high tech case
c  the factor is the percentage difference between the target
c  uec and the model uec for the ENDYR, normally 2015 or 2020

C ***** LBNL HITECH FLAG *****
      IF(IYR.GT.1998.AND.HITECH.EQ.1) THEN
       if(inddir.le.6.and.ifloc(ifuel,istep).ne.17) then ! asphalt is in calpatot
        DO IV = 1,3
C *** LBNL --- HITECH MODIFICATIONS ***
           IF (inddir.eq.1) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1            (1. + (-0.190)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.2) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.3) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1            (1. + (-0.170)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.4) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))              
           ENDIF
           IF (inddir.eq.5) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1            (1. + (-0.220)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.6 .AND. IFUEL.eq.1) THEN
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1             (1. + (-0.15)*(float(IYR-1998)/float(endyr-1998)))
           ELSE
              ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1             (1. + (-0.001)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           
        ENDDO
       endif
      ENDIF


C****
C  FORMAT STATEMENTS.
C****

  802 FORMAT(1X,'CSC1LAG PROBLEM. IV,IFUEL,ISTEP,UEC: ',3I3,1X,F7.3)
  803 FORMAT(1X,F7.3)
  991 FORMAT(3X,'CALCSC1')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  CONSERVATION/TECHNOLOGICAL SAVINGS CURVES.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 2 (ECONOMETRIC ESTIMATED EQUATION)
C****
      SUBROUTINE CALCSC2(IFUEL,ISTEP)
      IMPLICIT NONE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDALL)

      INTEGER IFUEL,ISTEP,iv

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  FOR EACH PROCESS STEP, AND EACH FUEL,
C  IF THE LAGGED TOTAL THROUGHPUT FOR A PROCESS STEP IS NOT ZERO,
C  THEN CALCULATE THE CSC CURVE ENERGY SAVINGS BASED UPON THE
C  CHANGE IN THE TOTAL CUMULATIVE OUTPUT.
C  IF THE LAGGED TOTAL CUMULATIVE OUTPUT IS
C  ZERO, THEN LET THE ENERGY SAVINGS THIS YEAR BE THE SAME AS IT
C  WAS IN THE PREVIOUS YEAR.
C****

C****
C    CALCULATE ENERGY SAVINGS FOR OLD VINTAGE.
C****
      IF(IYR.GT.1998.AND.FRZTECH.EQ.1) THEN
         BCSC(1,IFUEL,ISTEP) = 0.0
         BCSC(3,IFUEL,ISTEP) = 0.0
      ENDIF

      IF(CUMOUT(4,ISTEP).GT.0.0)THEN
        CSCCUR(1,IFUEL,ISTEP)=CUMOUT(4,ISTEP)**
     1                             BCSC(1,IFUEL,ISTEP)
      ELSE
        CSCCUR(1,IFUEL,ISTEP)=1.0
      ENDIF

C****
C    CALCULATE ENERGY SAVINGS FOR NEW VINTAGE.
C****

      IF(CUMOUT(4,ISTEP).GT.0.0)THEN
        CSCCUR(3,IFUEL,ISTEP)=CUMOUT(4,ISTEP)**
     1                             BCSC(3,IFUEL,ISTEP)
      ELSE
        CSCCUR(3,IFUEL,ISTEP)=1.0
      ENDIF

C****
C    CALCULATE UECS.
C****

C****
C    FROZEN TECHNOLOGY SCENARIO
C****
       IF(IYR.GT.1998.AND.FRZTECH.EQ.1) THEN
         CSCCUR(1,IFUEL,ISTEP) = 1.0
         CSCCUR(3,IFUEL,ISTEP) = 1.0
         EINTER(3,IFUEL,ISTEP) = EINTER(1,IFUEL,ISTEP)
       ENDIF
C****
C       CALCULATE OLD AND NEW UECS.
C****

        ENPINT(1,IFUEL,ISTEP)=EINTER(1,IFUEL,ISTEP)*
     1                   CSCCUR(1,IFUEL,ISTEP)
        ENPINT(3,IFUEL,ISTEP)=EINTER(3,IFUEL,ISTEP)*
     1                   CSCCUR(3,IFUEL,ISTEP)
         
C****
C    HIGH TECHNOLOGY SCENARIO
C****
C ***** LBNL HITECH FLAG *****

         IF(IYR.GT.1998.AND.HITECH.EQ.1) THEN
          DO IV = 1,3
           if(inddir.le.6.and.ifloc(ifuel,istep).ne.17) then ! asphalt is in calpatot
C *** LBNL HI TECH MODIFICATIONS 
              IF (inddir.eq.1) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.190)*(float(IYR-1998)/float(endyr-1998)))                
              ENDIF
              IF (inddir.eq.2) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))               
              ENDIF
              IF (inddir.eq.3) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.170)*(float(IYR-1998)/float(endyr-1998)))                
              ENDIF
              IF (inddir.eq.4) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))              
              ENDIF
              IF (inddir.eq.5) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.220)*(float(IYR-1998)/float(endyr-1998)))               
              ENDIF
              IF (inddir.eq.6 .AND. IFUEL.EQ.1) THEN
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1                (1. + (-0.15)*(float(IYR-1998)/float(endyr-1998)))      
              ELSE
                 ENPINT(IV,IFUEL,ISTEP) = ENPINT(IV,IFUEL,ISTEP) *
     1               (1. + (-0.001)*(float(IYR-1998)/float(endyr-1998)))             
              ENDIF

           ENDIF

           IF(INDDIR.EQ.14) THEN
            ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1      (1. + (-0.13)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF

           IF(INDDIR.EQ.15) THEN
              IF (IFUEL.EQ.1) THEN
                 ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1                (1. + (-0.26)*(float(IYR-1998)/float(endyr-1998)))
              ELSE
                 ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1                (1. + (-0.20)*(float(IYR-1998)/float(endyr-1998)))
              ENDIF
           ENDIF
          ENDDO
         ENDIF

          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1)THEN
            WRITE(IUNIT1,802)ITYPE(IFUEL,ISTEP)
            WRITE(IUNIT1,803)ENPINT(1,IFUEL,ISTEP),
     1         ENPINT(3,IFUEL,ISTEP)

        ENDIF

C****
C       CALCULATE UECS FOR MIDDLE VINTAGE.
C       IT IS THE WEIGHTED AVERAGE OF UECS FROM 1991 TO
C       THE LAG OF THE FORECAST YEAR.
C****

      IF(CUMPROD(3,ISTEP).GT.0.0) THEN
        ENPINT(2,IFUEL,ISTEP)=SUMPINT(IFUEL,ISTEP)/CUMPROD(3,ISTEP)
      ELSE
        ENPINT(2,IFUEL,ISTEP)=0.0
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  802 FORMAT(1X,'CSC2LAG PROBLEM. ITYPE: ',I3)
  803 FORMAT(1X,2F7.3)
  991 FORMAT(3X,'CALCSC2')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  CONSERVATION/TECHNOLOGICAL SAVINGS CURVES.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 3 (ADL APPROACH)
C****
      SUBROUTINE CALCSC3(IFUEL,ISTEP)
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(APQ)
      INCLUDE(INDALL)

      INTEGER IFUEL,ISTEP,IV
      REAL TCAL,UEC(20)
      REAL BETA(10),MINREI
      REAL INDPRICE(4) 
      REAL DELTA
      REAL TEMPTPC
      real tcal1,tcal2,exp1,exp2
      INTEGER CASE,IR,IY

      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW
c Modifications for Price Sensitivity based on ADL 5/97 Report
      integer i,j,irr,iunit_csc,readonce/0/,indus,vint,iyy,
     1 pSteam,pHeat,MotDrv,NonMot,nuses,nvints,iheat,ifx,ivv
      real pRat,Pt,Po ,oldpint(2,3)
      parameter(pSteam=1,pHeat=2,MotDrv=1,NonMot=2,nuses=2,nvints=3)
       
      real fUnew(7:13,nuses,nvints)   ! ratio of minimum practical UEC to base year UEC-91
      real Uexpnew(7:13,nuses,nvints) ! Nonelectric UEC Price Elasticity
      real ElecExp(7:13,nuses,nvints) ! Electricity UEC Price Elasticity  
      real payback(7:13,nvints)       ! payback period
      real markpen(7:13,nvints)       ! market penetration factor
      real omfract(7:13,nvints)       ! Annual O&M cost as fraction of an energy saving capital investment
      real pci(nvints)                ! Potential Capital Investment
      real ues(nvints)                ! Unit Energy Savings (uec-uecnew)*markpen (mmbtu/ton)
      real uci(nvints)                ! Unit Capital Investment ($/ton)
      real tci(nvints)                ! Total Capital Investment (uci*prodcur)(million$)
      real ici(nvints)                ! incremental Capital Investment
      real uecnew(nvints)             ! The new uec after price-induced energy saving investment made
      real sumtci(7:13,mnumyr)        ! yearly, national sum of  total cap investemnt
      integer ifuelstep               ! the current fuel-step combination
      character*133 line              ! temp variable to read a line from the input file
 
       DATA BETA/0.0,-0.1,-0.2,-0.25,
     1           -0.3,-0.4,-0.5,-0.6,-0.65,-0.7/
c
      if(readonce.eq.0) then
        readonce=1
        fname='INDCSC'
        new=.false.
        iunit_csc=file_mgr('O',fname,new)
        do i=1,3
          read(iunit_csc,'(a)') ! skip a line
        enddo
        do i=7,13
          do iv=1,2
            read(iunit_csc,'(a)',end=13) line
            line(1:7)=' '
            read(line,*) indus,vint,
     1          fUnew(indus,pSteam,vint),
     1          fUnew(indus,pHeat, vint),
     1        Uexpnew(indus,pSteam,vint),
     1        Uexpnew(indus,pHeat ,vint),
     1        ElecExp(indus,MotDrv,vint),
     1        ElecExp(indus,NonMot,vint),
     1        payback(indus,vint),
     1        markpen(indus,vint),
     1        omfract(indus,vint)
          enddo
        enddo
      endif
13    continue


      CASE=1
      MINREI = .4
      DELTA = 0.0
      IY = IYR - 1989
      IR = INDREG

c first time through for this industry, initialize investment accumulator
      if(ir.eq.1.and.ifuel.eq.1.and.istep.eq.1) then
         sumtci(inddir,iy)=0.
      endif
      do iv=1,3
        oldpint(1,iv)=enpint(iv,ifuel,istep)
      enddo
C***
C    CHECK TPC SENSITIVITY FLAG "ITPC" SET TO ONE. IF SO
C    APPLY TPC MULTIPLIER "TPC" IN YEAR 1999 forward
C***
C *** TPC FLAG *** LBNL

        IF(IYR.GT.1998.AND.ITPC.EQ.1) THEN
C *** LBNL *** HIEFF MODIFICATIONS TO ENERGY INTENSIVE INDUSTRIES ***
          IF (inddir.eq.7 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 4.0 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 4.0 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.7 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 4.0 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 4.0 *BCSC(3,IFUEL,ISTEP)   
          ELSE IF (inddir.eq.8 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 2.2 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 2.2 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.8 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.8 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.8 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.9 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 3.0 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 3.0 *BCSC(3,IFUEL,ISTEP)             
          ELSE IF (inddir.eq.9 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.2 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.2 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.10 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.5 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.5 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.10 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.7 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.7 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.11 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.9 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.9 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.11 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.7 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.7 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.12 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 1.1 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 1.1 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir .eq.12 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 4.0 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 4.0 *BCSC(3,IFUEL,ISTEP)     
          ELSE IF (inddir.eq.13 .AND. IFUEL.EQ.1) THEN
             BCSC(1,IFUEL,ISTEP)= 3.5 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 3.5 *BCSC(3,IFUEL,ISTEP)
          ELSE IF (inddir.eq.13 .AND. IFUEL.GT.1) THEN
             BCSC(1,IFUEL,ISTEP)= 4.0 *BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)= 4.0 *BCSC(3,IFUEL,ISTEP)
          ELSE
             BCSC(1,IFUEL,ISTEP)=TPC1*BCSC(1,IFUEL,ISTEP)
             BCSC(3,IFUEL,ISTEP)=TPC2*BCSC(3,IFUEL,ISTEP)
          ENDIF

       ENDIF

        IF(IYR.GT.1998.AND.FRZTECH.EQ.1) THEN
          BCSC(1,IFUEL,ISTEP)=0.0
          BCSC(3,IFUEL,ISTEP)=0.0
        ENDIF

        TCAL=BCSC(1,IFUEL,ISTEP)*(IYR-1990)
 
        CSCCUR(1,IFUEL,ISTEP)=MAX(MINREI,EXP(TCAL))

        TCAL=BCSC(3,IFUEL,ISTEP)*(IYR-1990)
        CSCCUR(3,IFUEL,ISTEP)=MAX(MINREI,EXP(TCAL))

        ENPINT(1,IFUEL,ISTEP)=EINTER(1,IFUEL,ISTEP)*
     1                   CSCCUR(1,IFUEL,ISTEP)

        ENPINT(3,IFUEL,ISTEP)=EINTER(3,IFUEL,ISTEP)*
     1                   CSCCUR(3,IFUEL,ISTEP)

C   Set UEC-Mid vintage as production-weighted average of uec's past.
      IF(CUMPROD(3,ISTEP).GT.0.0) THEN
        ENPINT(2,IFUEL,ISTEP)=SUMPINT(IFUEL,ISTEP)/CUMPROD(3,ISTEP)
      ELSE
        ENPINT(2,IFUEL,ISTEP)=0.0
      ENDIF
C Instead of using EINTER (the base year UEC), use
c last year's UEC and implement one year's worth of 
c technological progress.  This will allow any improvements
c due to price factors to be incorporated as well.  
c  Also, Apply tech progress
c to the mid-vintage productive capacity--An change for AEO98.  The
c rate of tech progress for mid-vintage is assumed to be half the
c rate of brand new productive capacity.
        
        DO IV=1,3,2
          ENPINT(IV,IFUEL,ISTEP)=ENPINTLAG(IV,IFUEL,ISTEP)*
     1   exp(bcsc(iv,ifuel,istep))
        ENDDO
        if(prodlag(2,istep)+prodlag(3,istep).gt.0.0) THEN
 
          ENPINT(2,IFUEL,ISTEP)=  
     1    ((prodlag(2,ISTEP)*ENPINTLAG(2,IFUEL,ISTEP)+
     2     prodlag(3,ISTEP)*ENPINTLAG(3,IFUEL,ISTEP))/
     3     (prodlag(2,istep)+prodlag(3,istep)))
     4     *exp(bcsc(2,ifuel,istep)/4.)  ! one-fourth the rate of new stuff
        ENDIF

        IF (INDDIR.EQ.12) THEN
           IF(ISTEP.EQ.1) THEN

             ENPINT(3,1,ISTEP)=EINTER(3,1,ISTEP)*CSCCUR(3,1,ISTEP)*
     1       (0.20+((0.21-0.20)*(IYR-1990))/25)/0.20   !ELECTRIC
             ENPINT(3,3,ISTEP)=EINTER(3,3,ISTEP)*CSCCUR(3,3,ISTEP)*
     1       (0.38+((0.31-0.38)*(IYR-1990))/25)/0.38     !NAT GAS
             ENPINT(3,4,ISTEP)=EINTER(3,4,ISTEP)*CSCCUR(3,4,ISTEP)*
     1       (0.007+((0.006-0.007)*(IYR-1990))/25)/0.007  !RESID
             ENPINT(3,5,ISTEP)=EINTER(3,5,ISTEP)*CSCCUR(3,5,ISTEP)*
     1     (0.001+((0.0008-0.001)*(IYR-1990))/25)/0.001 !DISTILL ATE
             ENPINT(3,6,ISTEP)=EINTER(3,6,ISTEP)*CSCCUR(3,6,ISTEP)*
     1       (0.001+((0.0008-0.001)*(IYR-1990))/25)/0.001   !LPG
             ENPINT(3,7,ISTEP)=EINTER(3,7,ISTEP)*CSCCUR(3,7,ISTEP)*
     1  (0.0002+((0.00016-0.0002)*(IYR-1990))/25)/0.0002 !PET COKE
             ENPINT(3,8,ISTEP)=EINTER(3,8,ISTEP)*CSCCUR(3,8,ISTEP)*
     1  (0.002+((0.0016-0.002)*(IYR-1990))/25)/0.002  !OTH PET
             ENPINT(3,2,ISTEP)=EINTER(3,2,ISTEP)*CSCCUR(3,2,ISTEP)*
     1             (0.41+((0.47-0.41)*(IYR-1990))/25)/0.41 !STEAM

           ENDIF

          IF(ISTEP.EQ.6) THEN
            ENPINT(1,3,ISTEP)=EINTER(1,3,ISTEP)*CSCCUR(1,3,ISTEP)*
     1          (0.06+((.26-0.06)*(IYR-1990))/25)/0.06 !NAT GAS
            ENPINT(1,10,ISTEP)=EINTER(1,10,ISTEP)*CSCCUR(1,10,ISTEP)*
     1          (0.77+((0.57-0.77)*(IYR-1990))/25)/0.77 !COKE
            ENPINT(3,10,ISTEP)=EINTER(3,10,ISTEP)*CSCCUR(3,10,ISTEP)*
     1          (.82+((0.00-.82)*(IYR-1990))/25)/.82!COKE
            ENPINT(3,2,ISTEP)=EINTER(3,2,ISTEP)*CSCCUR(3,2,ISTEP)*
     1          (0.01+((0.53-0.01)*(IYR-1990))/25)/0.01!STEAM COAL
            ENPINT(3,3,ISTEP)=EINTER(3,3,ISTEP)*CSCCUR(3,3,ISTEP)*
     1          (0.07+((0.36-0.07)*(IYR-1990))/25)/0.07!NAT GAS
          ENDIF

      ENDIF
      IF(INDDIR.EQ.11) THEN
        IF(ISTEP.EQ.2) THEN
 
          ENPINT(3,1,ISTEP)=EINTER(3,1,ISTEP)*CSCCUR(3,1,ISTEP)*
     1     (0.17+((0.21-0.17)*(IYR-1990))/25)/0.17 !ELECTRICITY
         ENPINT(3,2,ISTEP)=EINTER(3,2,ISTEP)*CSCCUR(3,2,ISTEP)*
     1     (0.154+((0.147-0.154)*(IYR-1990))/25)/0.154 !NAT GAS
          ENPINT(3,5,ISTEP)=EINTER(3,5,ISTEP)*CSCCUR(3,5,ISTEP)*
     1     (0.53+((0.505-0.53)*(IYR-1990))/25)/0.53   !COAL
          ENPINT(3,3,ISTEP)=EINTER(3,3,ISTEP)*CSCCUR(3,3,ISTEP)*
     1     (0.004+((0.0038-0.004)*(IYR-1990))/25)/0.004 !RESID
          ENPINT(3,4,ISTEP)=EINTER(3,4,ISTEP)*CSCCUR(3,4,ISTEP)*
     1     (0.023+((0.022-0.023)*(IYR-1990))/25)/0.023  !DIST
          ENPINT(3,6,ISTEP)=EINTER(3,6,ISTEP)*CSCCUR(3,6,ISTEP)*
     1     (0.118+((0.112-0.118)*(IYR-1990))/25)/0.118 !OTH PET
        ENDIF

      ENDIF
        do iv=1,3
          oldpint(2,iv)=enpint(iv,ifuel,istep)
        enddo
c Alter UEC based on price-induced conservation investments.  
C This follows the Approach suggested in the ADL report 5/97 

      ifx=ifloc(ifuel,istep)
      Pt=prcx(ifx,ir)           ! 4-region level ir
      Po=0.
      do iyy=2,iy-1
        Po=max(Po,prcxyr(ifx,ir,iyy))
      enddo
c      Po=prcxyr(ifx,ir,iy-1) 
      pRat=1.
      if(Po.gt.0.) then
        pRat=max(1.,Pt/Po)  ! must be at least 1 --no invest if prices go down
      endif

      do iv=1,3   ! vintage old, mid, new
        ues(iv)=0. 
        uecnew(iv)=0.
        pci(iv)=0.
        uci(iv)=0.
        tci(iv)=0.
      enddo

      do iv=1,3
        ivv=iv 
        if(iv.eq.2)ivv=1 
        uecnew(iv)=enpint(iv,IFUEL,ISTEP)  ! default value

        PCI(iv)=Payback(inddir,ivv)*Pt/    ! pci uses current price level not ratio
     1    (1.+payback(inddir,ivv)*omfract(inddir,ivv))

        if(ifx.eq.1) then                   ! electricity
          uecnew(iv)=enpint(iv,IFUEL,ISTEP)*
     1            pRat**ElecExp(inddir,MotDrv,ivv)
        else
          iheat=0
          if(ifx.ge.3.and.ifx.le.21) then     ! fuel 
            iheat=pHeat
          elseif(ifx.eq.31)  then             ! steam
            iheat=pSteam
          endif
          if(iheat.gt.0) then 
            uecnew(iv)=enpint(iv,IFUEL,ISTEP)*
     1      (fUnew(inddir,iheat,ivv)+ 
     1      ((1.-fUnew(inddir,iheat,ivv))*
     1      pRat**UexpNew(inddir,iheat,ivv))) ! Uexpnew is negative
          endif 
        endif
        ues(iv)=(enpint(iv,IFUEL,ISTEP)-UECNEW(iv))*
     1             markpen(inddir,ivv)
        uci(iv)=ues(iv)*pci(iv)
        tci(iv)=uci(iv)*prodcur(iv,istep)
        if(idval.eq.1) then
          tci(iv)=tci(iv)*.001
        else
          tci(iv)=tci(iv)*1000.
        endif
        sumtci(inddir,iy)=sumtci(inddir,iy)+tci(iv)
        enpint(iv,ifuel,istep)=enpint(iv,ifuel,istep)-ues(iv)
      enddo
      if(ifuel.eq.1.and.istep.eq.1) then ! .and.ir.eq.1) then
         IF(PRTDBGI.GT.1) THEN
        write(6,1000) indname
1000    format(1x,a/1x,'Year IR INDDIR ISTEP  IFX ',
     1     '     Pt      pRat  iv',
     1    ' oldpint1 oldpint2   enpint      ues      ',
     1       'pci     prodcur      tci')
 
1001    format(1x,i4,i3,i5,i7,i6,2f9.4,
     1      i4,3f9.4,f9.7,f9.5,f12.1,f9.2)
         ENDIF
      endif
      IF(PRTDBGI.GT.1) THEN
c      if(ifx.eq.31) then
        write(6,1001) (iyr,ir,inddir,istep,ifx,
     1    pt,Prat,
     1    iv,
     1    oldpint(1,iv),
     1    oldpint(2,iv),
     1    enpint(iv,ifuel,istep),
     1    ues(iv),
     1    pci(iv),
     2    prodcur(iv,istep),
     2    tci(iv),iv=1,3)
c       endif
       ENDIF 
 
 
      IF(PRTDBGI.GT.1) THEN
      if(ir.eq.4.and.ifuel.eq.ifmax(istep).and.istep.eq.MPASTP) then
        write(6,'(a,f13.4)') indname//' Total investment(iy)  =',
     1   sumtci(inddir,iy)
      endif
      ENDIF

c     IF(IYR.GT.1997.AND.FRZTECH.EQ.1) THEN
c       ENPINT(1,IFUEL,ISTEP) = ENPINTLAG(1,IFUEL,ISTEP)
c       ENPINT(2,IFUEL,ISTEP) = ENPINTLAG(2,IFUEL,ISTEP)
c       ENPINT(3,IFUEL,ISTEP) = ENPINT(1,IFUEL,ISTEP)
c     ENDIF
  991 FORMAT(3X,'CALCSC3')
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE UPDATES THE UEC'S CALCULATED IN SUBROUTINE
C  CALCSC BASED ON PRICE RELATED ENERGY CONSERVATION.
C****
      SUBROUTINE CALPRC
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IS,IF

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE UECS
C****

      DO 20 IS=1,MPASTP
        DO 10 IF=1,IFMAX(IS)

        IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) WRITE(IUNIT1,900)ITYPE(IF,IS)
C****
C    CALCULATE UECS BASED ON EQUATION TYPE 1
C****

          IF(ITYPE(IF,IS).EQ.1) THEN
            IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) WRITE(IUNIT1,901)
            CALL CALPRC1(IF,IS)
          ENDIF
C****
C    CALCULATE ENERGY SAVINGS BASED ON EQUATION TYPE 2
C****

          IF(ITYPE(IF,IS).EQ.2) CALL CALPRC2(IF,IS)

C****
C    CALCULATE ENERGY SAVINGS BASED ON EQUATION TYPE 3
C****

C         IF(ITYPE(IF,IS).EQ.3) CALL CALPRC3(IF,IS)

 10     CONTINUE
 20   CONTINUE

C****
C  FORMAT STATEMENTS.
C****
  900 FORMAT(3X,'ITYPE',1X,I3)
  901 FORMAT(3X,'ITS A TYPE 1')
  991 FORMAT(3X,'CALPRC')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED PRICE
C  RELATED ENERGY CONSERVATION.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 1 (OLD APPROACH)
C****
      SUBROUTINE CALPRC1(IFUEL,ISTEP)
      IMPLICIT NONE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDALL)

      INTEGER IS,IF,IV,IFUEL,ISTEP,IFX
      REAL DELPRC,TPRC

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  FOR EACH PROCESS STEP, AND EACH FUEL,
C  IF THE LAGGED TOTAL THROUGHPUT FOR A PROCESS STEP IS NOT ZERO,
C  THEN CALCULATE THE PRICE RELATED ENERGY SAVINGS BASED UPON THE
C  CHANGE IN THE TOTAL PRODUCT.  IF THE LAGGED TOTAL THROUGHPUT IS
C  ZERO, THEN LET THE ENERGY SAVINGS THIS YEAR BE THE SAME AS IT
C  WAS IN THE PREVIOUS YEAR.
C****

       BELAS(1,IFUEL,ISTEP,1)=0.0
       BELAS(3,IFUEL,ISTEP,1)=0.0
       PRCCUR(1,IFUEL,ISTEP)=1.0
       PRCCUR(3,IFUEL,ISTEP)=1.0

C****
C    CALCULATE ENERGY SAVINGS FOR OLD VINTAGE.
C****

         PRCCUR(1,IFUEL,ISTEP)=PRCLAG(1,IFUEL,ISTEP)

C****
C    CALCULATE ENERGY SAVINGS FOR NEW VINTAGE.
C****
          PRCCUR(3,IFUEL,ISTEP)=PRCLAG(3,IFUEL,ISTEP)

C****
C    CALCULATE ENERGY SAVINGS FOR MIDDLE VINTAGE.
C    IF THE PRODUCTION FROM 1991 TO THE CURRENT FORECAST YEAR IS
C    NOT ZERO, THEN THE MIDDLE VINTAGE ENERGY SAVINGS IS A WEIGHTED
C    AVERAGE OF THE MIDDLE FROM THE PREVIOUS YEAR AND THE NEW IN THIS
C    YEAR.
C****

         PRCCUR(2,IFUEL,ISTEP)=PRCLAG(2,IFUEL,ISTEP)

C****
C    CALCULATE UECS.
C****

      DO 70 IV=1,3
         ENPINT(IV,IFUEL,ISTEP)=ENPINTLAG(IV,IFUEL,ISTEP)
         PRCLAG(IV,IFUEL,ISTEP)=PRCCUR(IV,IFUEL,ISTEP)
          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) THEN
             WRITE(IUNIT1,802) IV,IFUEL,ISTEP,ENPINT(IV,IFUEL,ISTEP)
             WRITE(IUNIT1,803) PRCLAG(IV,IFUEL,ISTEP)
          ENDIF
   70 CONTINUE

c *** hitech scenario for type 1 ***
C ***** LBNL HITECH FLAG *****

      if (iyr.gt.1998.and.hitech.eq.1) then
        do iv=1,3
           if(inddir.le.6.and.ifloc(ifuel,istep).ne.17) then ! asphalt is in calpatot

C LBNL *** HITECH MODIFICATIONS
           IF (inddir.eq.1) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.190)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.2) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.3) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.170)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.4) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))        
           ENDIF
           IF (inddir.eq.5) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.220)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.6 .AND. IFUEL.EQ.1) THEN
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.15)*(float(IYR-1998)/float(endyr-1998)))
           ELSE
              ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1            (1. + (-0.001)*(float(IYR-1998)/float(endyr-1998)))
          ENDIF
           
        ENDIF

           IF(INDDIR.EQ.14) THEN
            ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1      (1. + (-0.13)*(float(IYR-1998)/float(endyr-1998)))
          ENDIF

           IF(INDDIR.EQ.15) THEN
              IF (IFUEL.EQ.1) THEN
                  ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1                (1. + (-0.26)*(float(IYR-1998)/float(endyr-1998)))                
              ELSE
                 ENPINT(iv,IFUEL,ISTEP) = ENPINT(iv,IFUEL,ISTEP)*
     1                (1. + (-0.20)*(float(IYR-1998)/float(endyr-1998)))
              ENDIF
           ENDIF
        enddo
       ENDIF


C****
C  FORMAT STATEMENTS.
C****

  802 FORMAT(1X,'PRC1LAG PROBLEM. IV,IFUEL,ISTEP,UEC: ',3I3,1X,F7.3)
  803 FORMAT(1X,F7.3)
  991 FORMAT(3X,'CALPRC1')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  PRICE RELATED CONSERVATION.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 2 (ECONOMETRIC ESTIMATED EQUATION)
C****
      SUBROUTINE CALPRC2(IFUEL,ISTEP)
      IMPLICIT NONE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDALL)

      INTEGER IFUEL,ISTEP,IFX,IT
      REAL WPRC(11)

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  FOR EACH FUEL,
C  CALCULATE THE APPLICABLE AVERAGE PRICES TO ACCOMMODATE
C  THE EQUATION.
C****

      IFX=IFLOC(IFUEL,ISTEP)
      WPRC(1)=PRCX(IFX,INDREG)                          !OWN
      WPRC(2)=PRCX(1,INDREG)                            !ELECTRICITY
      WPRC(3)=PRCX(3,INDREG)                            !NATURAL GAS
      WPRC(4)=PRCX(7,INDREG)                            !STEAM COAL
      IF (INDDIR.LT.7) THEN
        WPRC(5)=PRCX(10,INDREG)                        !OIL
      ELSE
        WPRC(5)=PRCX(11,INDREG)
      ENDIF
      WPRC(6)=PRCX(14,INDREG)                           !MOTOR GAS
      WPRC(7)=PRCX(17,INDREG)                           !ASPHALT
      WPRC(8)=1.0                                !OTHER
      IF(INDDIR.NE.9) THEN
         WPRC(9)=PRCX(12,INDREG)            !LPG FOR HEAT AND POWER
      ELSE
         WPRC(9)=PRCX(13,INDREG)            !LPG FOR FEEDSTOCKS
      ENDIF
      WPRC(10)=PRCX(11,INDREG)           !DISTILLATE OIL
      WPRC(11)=PRCX(10,INDREG)           !RESIDUAL OIL

C****
C  FOR EACH PROCESS STEP, AND EACH FUEL,
C  CALCULATE THE PRICE ENERGY SAVINGS BASED UPON THE
C  CHANGE IN THE FUEL PRICES.
C****

C****
C    CALCULATE ENERGY SAVINGS FOR OLD VINTAGE.
C****

        PRCCUR(1,IFUEL,ISTEP)=1.0
        DO IT=1,11
          IF(WPRC(IT).GT.0.0.AND.BELAS(1,IFUEL,ISTEP,IT).NE.0.0)
     1    PRCCUR(1,IFUEL,ISTEP)=PRCCUR(1,IFUEL,ISTEP)*
     1              (WPRC(IT)**BELAS(1,IFUEL,ISTEP,IT))
        ENDDO


C****
C    CALCULATE ENERGY SAVINGS FOR NEW VINTAGE.
C****

        PRCCUR(3,IFUEL,ISTEP)=1.0
        DO IT=1,11
          IF(WPRC(IT).GT.0.0.AND.BELAS(3,IFUEL,ISTEP,IT).NE.0.0)
     1    PRCCUR(3,IFUEL,ISTEP)=PRCCUR(3,IFUEL,ISTEP)*
     1              (WPRC(IT)**BELAS(3,IFUEL,ISTEP,IT))
        ENDDO


C****
C    CALCULATE UECS.
C****

C****
C       CALCULATE OLD AND NEW UECS.
C****

C  frozen technology scenario

        if(iyr.gt.1998.and.frztech.eq.1) then
          ENPINT(1,IFUEL,ISTEP) = ENPINTLAG(1,IFUEL,ISTEP)
          ENPINT(2,IFUEL,ISTEP) = ENPINTLAG(1,IFUEL,ISTEP)
          ENPINT(3,IFUEL,ISTEP) = ENPINTLAG(1,IFUEL,ISTEP)
        ELSE 
        ENPINT(1,IFUEL,ISTEP)=ENPINTLAG(1,IFUEL,ISTEP)*
     1                   PRCCUR(1,IFUEL,ISTEP)
        ENPINT(3,IFUEL,ISTEP)=ENPINTLAG(3,IFUEL,ISTEP)*
     1                   PRCCUR(3,IFUEL,ISTEP)
        ENDIF
          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) THEN
             WRITE(IUNIT1,802) ITYPE(IFUEL,ISTEP)
             WRITE(IUNIT1,803) ENPINT(1,IFUEL,ISTEP),
     1               ENPINT(3,IFUEL,ISTEP)
          ENDIF


c *** hitech scenario for type 1 ***
C ***** LBNL HITECH FLAG *****

      if (iyr.gt.1998.and.hitech.eq.1) then
        do it=1,3
           if(inddir.le.6.and.ifloc(ifuel,istep).ne.17) then ! asphalt is in calpatot
C *** LBNL HITECH MODIFICATIONS ***
           IF (inddir.eq.1) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.190)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.2) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.3) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.170)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.4) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.5) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.220)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.6 .AND. IFUEL.EQ.1) THEN
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.15)*(float(IYR-1998)/float(endyr-1998)))
           ELSE
              ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1            (1. + (-0.001)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           
        ENDIF

           IF(INDDIR.EQ.14) THEN
            ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1      (1. + (-0.13)*(float(IYR-1998)/float(endyr-1998)))
          ENDIF

           IF(INDDIR.EQ.15) THEN
              IF (IFUEL.EQ.1) THEN
                 ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1                (1. + (-0.26)*(float(IYR-1998)/float(endyr-1998)))
              ELSE
                 ENPINT(it,IFUEL,ISTEP) = ENPINT(it,IFUEL,ISTEP)*
     1                (1. + (-0.20)*(float(IYR-1998)/float(endyr-1998)))
              ENDIF
           ENDIF
        enddo
      ENDIF


C****
C       DO NOT CALCULATE ANYMORE THE MIDDLE VINTAGE UECS.
C       THEY HAVE BEEN CALCULATED IN CALCSC2.
C****

C****
C  FORMAT STATEMENTS.
C****

  802 FORMAT(1X,'PRC2LAG PROBLEM. ITYPE',I3)
  803 FORMAT(1X,F7.3,F7.3)
  991 FORMAT(3X,'CALPRC2')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  PRICE RELATED CONSERVATION.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 3 (ADL APPROACH??)
C****
      SUBROUTINE CALPRC3(IFUEL,ISTEP)
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IFUEL,ISTEP,IFX,IT
      REAL WPRC(11)

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  FOR EACH FUEL,
C  CALCULATE THE APPLICABLE AVERAGE PRICES TO ACCOMMODATE
C  THE EQUATION.
C****

      IFX=IFLOC(IFUEL,ISTEP)
      WPRC(1)=PRCX(IFX,INDREG)                   !OWN
      WPRC(2)=PRCX(1,INDREG)                     !ELECTRICITY
      WPRC(3)=PRCX(3,INDREG)                     !NATURAL GAS
      WPRC(4)=PRCX(7,INDREG)                     !STEAM COAL
      IF(INDDIR.LT.7) THEN
        WPRC(5)=PRCX(10,INDREG)                  !OIL
      ELSE
        WPRC(5)=PRCX(11,INDREG)
      ENDIF
      WPRC(6)=PRCX(14,INDREG)                    !MOTOR GAS
      WPRC(7)=PRCX(17,INDREG)                    !ASPHALT
      WPRC(8)=1.0                                !OTHER
      IF(INDDIR.NE.9) THEN
        WPRC(9)=PRCX(12,INDREG)              !LPG FOR HEAT AND POWER
      ELSE
        WPRC(9)=PRCX(13,INDREG)              !LPG FOR FEEDSTOCKS
      ENDIF
      WPRC(10)=PRCX(11,INDREG)               !DISTILLATES
      WPRC(11)=PRCX(10,INDREG)               !RESIDUAL


C****
C  FOR EACH PROCESS STEP, AND EACH FUEL,
C  CALCULATE THE PRICE ENERGY SAVINGS BASED UPON THE
C  CHANGE IN THE FUEL PRICES.
C****

C****
C    CALCULATE ENERGY SAVINGS FOR OLD VINTAGE.
C****

        PRCCUR(1,IFUEL,ISTEP)=1.0
        DO IT=1,11
          IF(WPRC(IT).GT.0.0.AND.BELAS(1,IFUEL,ISTEP,IT).NE.0.0)
     1    PRCCUR(1,IFUEL,ISTEP)=PRCCUR(1,IFUEL,ISTEP)*
     1              (WPRC(IT)**BELAS(1,IFUEL,ISTEP,IT))
        ENDDO

C****
C    CALCULATE ENERGY SAVINGS FOR NEW VINTAGE.
C****

        PRCCUR(3,IFUEL,ISTEP)=1.0
        DO IT=1,11
          IF(WPRC(IT).GT.0.0.AND.BELAS(3,IFUEL,ISTEP,IT).NE.0.0)
     1    PRCCUR(3,IFUEL,ISTEP)=PRCCUR(3,IFUEL,ISTEP)*
     1              (WPRC(IT)**BELAS(3,IFUEL,ISTEP,IT))
        ENDDO

C****
C    CALCULATE UECS.
C****

C****
C       CALCULATE OLD AND NEW UECS.
C****

         ENPINT(1,IFUEL,ISTEP)=ENPINT(1,IFUEL,ISTEP)*
     1                   PRCCUR(1,IFUEL,ISTEP)
        ENPINT(3,IFUEL,ISTEP)=ENPINT(3,IFUEL,ISTEP)*
     1                   PRCCUR(3,IFUEL,ISTEP)

          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1) THEN
             WRITE(IUNIT1,802) ITYPE(IFUEL,ISTEP)
             WRITE(IUNIT1,803) ENPINT(1,IFUEL,ISTEP),
     1               ENPINT(3,IFUEL,ISTEP)
          ENDIF
C****
C       DO NOT CALCULATE ANYMORE THE MIDDLE VINTAGE UECS.
C       THEY HAVE BEEN CALCULATED IN CALCSC3.
C****

C****
C  FORMAT STATEMENTS.
C****

  802 FORMAT(1X,'PRC3LAG PROBLEM. ITYPE',I3)
  803 FORMAT(1X,F7.3,F7.3)
  991 FORMAT(3X,'CALPRC3')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE CALTLOG
      IMPLICIT NONE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDALL)

      INTEGER I,IF,IS,IFL,IFX,IT,iq,IV
      INTEGER IFLAG,ARRAY_FUEL(6)
      REAL WPRC(11)
      REAL COSTSHR,QTY1,QTY2,T1,T2,T3
      REAL LC,COST,PRICE
      REAL D11,D12,D13,D14,D15,D22,D23,D24,D25,D33,D34,D35
      REAL D44,D45,D55,A0,A1,A2,A3,A4,A5
      REAL W1,W2,W3,W4,W5,W6
      REAL TLOG1,TLOG2
      DATA ARRAY_FUEL/3,7,1,10,11,12/
C****
C  FOR EACH FUEL,
C  CALCULATE THE APPLICABLE AVERAGE PRICES TO ACCOMMODATE
C  THE EQUATION.
C****

      WPRC(1)=PRCX(1,INDREG)                            !ELECTRICITY
      WPRC(3)=PRCX(3,INDREG)                            !NATURAL GAS
      WPRC(4)=PRCX(7,INDREG)                            !STEAM COAL
      IF(INDDIR.NE.9) THEN
         WPRC(9)=PRCX(12,INDREG)            !LPG FOR HEAT AND POWER
      ELSE
         WPRC(9)=PRCX(13,INDREG)            !LPG FOR FEEDSTOCKS
      ENDIF
      WPRC(11)=PRCX(11,INDREG)           !DISTILLATE OIL
      WPRC(10)=PRCX(10,INDREG)           !RESIDUAL OIL

C****
C ASSIGN FUELS PRICES AND TRANSLOG PARAMETERS TO DUMMY VARIABLES
C****
       W1 = WPRC(3)  ! natural gas
       W2 = WPRC(4)  ! steam coal
       W3 = WPRC(1)  ! electricity
       W4 = WPRC(11) ! distillate
       W5 = WPRC(10) ! residual
       W6 = WPRC(9)  ! lpg
       D11 = TLCOEF(INDDIR,1)
       D12 = TLCOEF(INDDIR,2)
       D13 = TLCOEF(INDDIR,3)
       D14 = TLCOEF(INDDIR,4)
       D15 = TLCOEF(INDDIR,5)
       D22 = TLCOEF(INDDIR,6)
       D23 = TLCOEF(INDDIR,7)
       D24 = TLCOEF(INDDIR,8)
       D25 = TLCOEF(INDDIR,9)
       D33 = TLCOEF(INDDIR,10)
       D34 = TLCOEF(INDDIR,11)
       D35 = TLCOEF(INDDIR,12)
       D44 = TLCOEF(INDDIR,13)
       D45 = TLCOEF(INDDIR,14)
       D55 = TLCOEF(INDDIR,15)
       A0 = TLCOEF(INDDIR,16)
       A1 = TLCOEF(INDDIR,17)
       A2 = TLCOEF(INDDIR,18)
       A3 = TLCOEF(INDDIR,19)
       A4 = TLCOEF(INDDIR,20)
       A5 = TLCOEF(INDDIR,21)

C****
C    INITIALIZE COST SHARES
C****
        S1 = 0.0
        S2 = 0.0
        S3 = 0.0
        S4 = 0.0
        S5 = 0.0
        S6 = 0.0
C****
C    CALCULATE TOTAL ENERGY COST AND FUEL COSTS SHARES
C****
        S1 = A1 + D11*LOG(W1/W6) + D12*LOG(W2/W6) + D13*LOG(W3/W6)
     1      + D14*LOG(W4/W6) + D15*LOG(W5/W6)
        S2 = A2+ D12*LOG(W1/W6) + D22*LOG(W2/W6) + D23*LOG(W3/W6)
     1      + D24*LOG(W4/W6) + D25*LOG(W5/W6)
        S3 = A3 + D13*LOG(W1/W6) + D23*LOG(W2/W6) + D33*LOG(W3/W6)
     1      + D34*LOG(W4/W6) +D35*LOG(W5/W6)
        S4 = A4 + D14*LOG(W1/W6) + D24*LOG(W2/W6) + D34*LOG(W3/W6)
     1      + D44*LOG(W4/W6) + D45*LOG(W5/W6)
        S5 = A5+ D15*LOG(W1/W6) + D25*LOG(W2/W6) + D35*LOG(W3/W6)
     1      + D45*LOG(W4/W6) + D55*LOG(W5/W6)


       TLOG1  = A0 + A1*LOG(W1) + A2*LOG(W2) + A3*LOG(W3) + A4*LOG(W4)
     1      + A5*LOG(W5) + (1-(A1+A2+A3+A4+A5))*LOG(W6)
     1      + (1/2)*((D11*LOG(W1)**2+ D12*LOG(W1)*LOG(W2)
     1      + D13*LOG(W1)*LOG(W3)
     1      + D14*LOG(W1)*LOG(W4) + D15*LOG(W1)*LOG(W5)
     1      + (-(D11+D12+D13+D14+D15))*LOG(W1)*LOG(W6)
     1      + D12*LOG(W2)*LOG(W1) + D22*LOG(W2)**2
     1      + D23*LOG(W2)*LOG(W3)
     1      + D24*LOG(W2)*LOG(W4) + D25*LOG(W2)*LOG(W5)
     1      + (-(D12+D22+D23+D24+D25))*LOG(W2)*LOG(W6)
     1      + D13*LOG(W3)*LOG(W1) + D23*LOG(W3)*LOG(W2)
     1      + D33*LOG(W3)**2
     1      + D34*LOG(W3)*LOG(W4) + D35*LOG(W3)*LOG(W5)
     1      + (-(D13+D23+D33+D34+D35))*LOG(W3)*LOG(W6)
     1      + D14*LOG(W4)*LOG(W1) + D24*LOG(W4)*LOG(W2)
     1      + D34*LOG(W4)*LOG(W3)
     1      + D44*LOG(W4)**2 + D45*LOG(W4)*LOG(W5)
     1      + (-(D14+D24+D34+D44+D45))*LOG(W4)*LOG(W6)))
     
        TLOG2 =  (1/2)*(D15*LOG(W5)*LOG(W1) + D25*LOG(W5)*LOG(W2)
     1      + D35*LOG(W5)*LOG(W3)
     1      + D45*LOG(W5)*LOG(W4) + D55*LOG(W5)**2
     1      + (-(D15+D25+D35+D45+D55))*LOG(W5)*LOG(W6)
     1      + (1-(A1+A2+A3+A4+A5))
     1      + (-(D11+D12+D13+D14+D15))*LOG(W6)*LOG(W1)
     1      + (-(D12+D22+D23+D24+D25))*LOG(W6)*LOG(W2)
     1      + (-(D13+D23+D33+D34+D35))*LOG(W6)*LOG(W3)
     1      + (-(D14+D24+D34+D44+D45))*LOG(W6)*LOG(W4)
     1      + (-(D15+D25+D35+D45+D55))*LOG(W6)*LOG(W5)
     1      - (-(D11+D12+D13+D14+D15)
     1         -(D12+D22+D23+D24+D25)
     1         -(D13+D23+D33+D34+D35)
     1         -(D14+D24+D34+D44+D45)
     1         -(D15+D25+D35+D45+D55))*LOG(W6)**2)+
     1          LOG(PRODCUR(4,1))
      COST = EXP(TLOG1+TLOG2)
C  CHECK TO SEE IF SHARE OF ONE OR MORE FUELS IS ZERO
         DO I = 1,5
          IFLAG = 0
          IFL = I
          DO IF = 1,IFMAX(1)
           IF(IFLAG.EQ.0) THEN
            IF(ARRAY_FUEL(I).EQ.IFLOC(IF,1)) THEN
              IFLAG = 1
            ENDIF
           ENDIF
          ENDDO
          IF(IFLAG.EQ.0) THEN
           IF(IFL.EQ.1)S1=0.0
           IF(IFL.EQ.2)S2=0.0
           IF(IFL.EQ.3)S3=0.0
           IF(IFL.EQ.4)S4=0.0
           IF(IFL.EQ.5)S5=0.0
           IF(IFL.EQ.6)S6=0.0
          ENDIF
         ENDDO

      S6=1-(S1 + S2 + S3 + S4 +S5)



C****
C   CHECK TO SEE IF ON OR MORE SHARES IS NEGATIVE
C   IF SO, SET TO ZERO AND REALLOCATE
C****
       IF(S1.LT.0.0.OR.S2.LT.0.0.OR.S3.LT.0.0.OR.S4.LT.0.0.OR
     1   .S5.LT.0.0.OR.S6.LT.0.0) CALL ZEROCHK

C****
C    CALCULATE UECS.
C****

C****
C       CALCULATE OLD AND NEW UECS.
C****
      DO 70 IS = 1,MPASTP
       DO 60 IF = 1,IFMAX(IS)
        IFX = IFLOC(IF,IS)
         IF(IFX.EQ.1.OR.IFX.EQ.3.OR.IFX.EQ.7.OR.IFX.EQ.10.OR
     1      .IFX.EQ.11.OR.IFX.EQ.12) THEN ! statement label 50

C****
C       CALCULATE OLD AND NEW UECS.
C****

      IF(IFX.EQ.1) THEN
         PRICE = W3
         COSTSHR = S3
      ENDIF
      IF(IFX.EQ.7) THEN
         PRICE = W2
         COSTSHR = S2
      ENDIF
      IF(IFX.EQ.11) THEN
         PRICE = W4
         COSTSHR = S4
      ENDIF
      IF(IFX.EQ.10) THEN
         PRICE = W5
         COSTSHR= S5
      ENDIF
      IF(IFX.EQ.12) THEN
         PRICE = W6
         COSTSHR = S6
      ENDIF
      IF(IFX.EQ.3) THEN
         PRICE = W1
         COSTSHR = S1
      ENDIF
 


C  BENCHMARK UEC'S TO 1991 VALUE CALCULATED BASED ON MECS DATA
      IF(IYR.EQ.1991) THEN
       T1=(COSTSHR*COST)/PRICE
       T2=ENPINTLAG(1,IF,1)*PRODCUR(4,1)
       T3=ENPINTLAG(3,IF,1)*PRODCUR(4,1)
       IF(T1.GT.0.0.AND.T2.GT.0.0.AND.T3.GT.0.0) THEN
         TLFAC(INDDIR,INDREG,1,IF,1)=
     1      (ENPINTLAG(1,IF,1)*PRODCUR(4,1)) / (COSTSHR*COST/PRICE)
         TLFAC(INDDIR,INDREG,3,IF,1)=
     1      (ENPINTLAG(3,IF,1)*PRODCUR(4,1)) / (COSTSHR*COST/PRICE)


        ENDIF
       ENDIF
c       TLFAC(INDNUM,INDREG,1,IF,1)=1.0   ! Temp Fix to Turnoff UEC Benchmarking
           QTY1 = (COSTSHR*COST/PRICE) *  TLFAC(INDDIR,INDREG,1,IF,1)

           QTY2 = (COSTSHR*COST/PRICE) *
     1       TLFAC(INDDIR,INDREG,3,IF,1)



         IF(QTY1.GT.0.001.AND.PRODCUR(4,1).GT.0.001) THEN
            ENPINT(1,IF,1)=  QTY1/PRODCUR(4,1)
         ELSE
            ENPINT(1,if,1)= 0.0
         ENDIF
         IF(QTY2.GT.0.001.AND.PRODCUR(4,1).GT.0.001) THEN
            ENPINT(3,IF,1)=  QTY2/PRODCUR(4,1)
         ELSE
            ENPINT(3,if,1)= 0.0
         ENDIF


            ENPINT(2,IF,1)=(ENPINT(1,IF,1)+
     1                           ENPINT(3,IF,1))/2

C****
C       CALCULATE UECS FOR the frozen technology
C       standalone case.
C****
       IF(IYR.GT.1998.AND.FRZTECH.EQ.1) THEN
         DO IV = 1,3
           ENPINT(IV,IF,1) = 1.015*ENPINT(IV,IF,1)
         ENDDO
       ENDIF
C****
C       CALCULATE UECS FOR the high efficiency
C       standalone case.
C****
C ***** LBNL HITECH FLAG *****

       IF(IYR.GT.1998.AND.HITECH.EQ.1) THEN
          IF(INDDIR.EQ.14) THEN
            DO IV = 1,3
               ENPINT(IV,IF,1) = ENPINT(IV,IF,1) *
     1      (1. + (-0.13)*(float(IYR-1998)/float(endyr-1998)))
            ENDDO
         ENDIF
         
         IF(INDDIR.EQ.15) THEN
            DO IV = 1,3
               IF (IF.EQ.1) THEN
                  ENPINT(IV,IF,1) = ENPINT(IV,IF,1) *
     1              (1. + (-0.26)*(float(IYR-1998)/float(endyr-1998)))
               ELSE
                  ENPINT(IV,IF,1) = ENPINT(IV,IF,1) *
     1              (1. + (-0.20)*(float(IYR-1998)/float(endyr-1998))) 
               ENDIF
               
            ENDDO
         ENDIF
         
      ENDIF

50         ENDIF ! end of condition statement checking for fuel types
60       CONTINUE ! end of the fuels loop
70      CONTINUE  ! end of the steps loop




      RETURN
      END

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THE BYPRODUCT ENERGY CONSUMPTION
C  IN THE PROCESS AND ASSEMBLY COMPONENT.  IT IS ASSUMED AT THIS
C  POINT (2/12/93) THAT ALL BYPRODUCT ENERGY IS CONSUMED IN
C  IN THE BOILER/STEAM COGEN COMPONENT.
C****
      SUBROUTINE CALBYPROD
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IS,IF,IV,IFX,IFY
      REAL DELPROD,TPROD

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE FOR EACH PROCESS STEP AND FOR EACH BYPRODUCT,
C  IF THE LAGGED TOTAL THROUGHPUT FOR A PROCESS STEP IS NOT ZERO,
C  THEN CALCULATE THE 'EFFICIENCY' OF WASTE MATERIALS PRODUCED
C  BASED ON SOME TECHNICAL EFFICIENCY.
C****
          
      DO 50 IS=1,MPASTP
      DO 50 IF=1,IFBYP(IS)
        IF(PRODLAG(4,IS).NE.0.0) THEN
          DELPROD=PRODCUR(4,IS)/PRODLAG(4,IS)
          IF (DELPROD.NE.0.0) THEN
Cepa            if(iyr.gt.1995) then
Cepa              bypcsc(1,if,is) = bypcsc(3,if,is)
Cepa            endif
            BYPCSCCUR(1,IF,IS)=DELPROD**BYPCSC(1,IF,IS)
            BYPCSCCUR(3,IF,IS)=DELPROD**BYPCSC(3,IF,IS)
          ENDIF
        ELSE
          BYPCSCCUR(1,IF,IS)=BYPCSCLAG(1,IF,IS)
          BYPCSCCUR(3,IF,IS)=BYPCSCLAG(3,IF,IS)
        ENDIF

C****
C  IF THE PRODUCTION FROM 1991 TO THE CURRENT FORECAST YEAR IS
C  NOT ZERO, THEN THE MIDDLE VINTAGE ENERGY SAVINGS IS A WEIGHTED
C  AVERAGE OF THE MIDDLE FROM THE PREVIOUS YEAR AND THE NEW IN THIS
C  YEAR.
C****

        TPROD=PRODCUR(3,IS)+PRODCUR(2,IS)
        IF(TPROD.NE.0.0) THEN
          BYPCSCCUR(2,IF,IS)=(PRODCUR(3,IS)*BYPCSCCUR(3,IF,IS)+
     1      PRODCUR(2,IS)*BYPCSCLAG(2,IF,IS))/TPROD
        ELSE
          BYPCSCCUR(2,IF,IS)=BYPCSCLAG(2,IF,IS)
        ENDIF
   50 CONTINUE

C****
C  CALCULATE THIS YEAR'S RATE OF BYPRODUCT ENERGY PRODUCED.
C****

      DO 60 IS=1,MPASTP
      DO 60 IF=1,IFBYP(IS)
      DO 60 IV=1,3
        IF(BYPCSCLAG(IV,IF,IS).EQ.0.0) THEN
          IF(IWDBG.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,802) IV,IF,IS
  802     FORMAT(1X,'BYPCSCLAG PROBLEM. IV,IF,IS: ',3I3)
        ENDIF
        BYPINT(IV,IF,IS)=BYPINTLAG(IV,IF,IS)*BYPCSCCUR(IV,IF,IS)
        BYPCSCLAG(IV,IF,IS)=BYPCSCCUR(IV,IF,IS)
   60 CONTINUE

C****
C  CALCULATE THE ENERGY BYPRODUCT PRODUCTION IN EACH PROCESS STEP.
C****

C  INITIALIZE BYPQTY

      DO IS=1,10
        DO IF=1,6
          DO IV=1,4
            BYPQTY(IV,IF,IS)=0.0
          ENDDO
        ENDDO
      ENDDO

      DO 70 IS=1,MPASTP
      DO 70 IF=1,IFBYP(IS)
        BYPQTY(1,IF,IS)=PRODCUR(1,IS)*BYPINT(1,IF,IS)
        BYPQTY(2,IF,IS)=PRODCUR(2,IS)*BYPINT(2,IF,IS)
        BYPQTY(3,IF,IS)=PRODCUR(3,IS)*BYPINT(3,IF,IS)
        BYPQTY(4,IF,IS)=BYPQTY(1,IF,IS)+BYPQTY(2,IF,IS)+
     1                                  BYPQTY(3,IF,IS)
   70 CONTINUE

C****
C  CONVERT MMBTU TO TRILLION BTU IF IDVAL=1.
C  DO NOT CONVERT IF IDVAL=2.
C****

      IF(IDVAL.EQ.1) THEN
        DO 80 IS=1,MPASTP
        DO 80 IF=1,IFBYP(IS)
        DO 80 IV=1,4
          BYPQTY(IV,IF,IS)=BYPQTY(IV,IF,IS)/1000000.0
 80     CONTINUE
      ENDIF

C****
C  SUM UP THE CONSUMPTION OVER THE FUEL TYPES.
C****

      DO 90 IS=1,MPASTP
      DO 90 IV=1,4
        BYPQTY(IV,6,IS)=0.0
        DO 90 IF=1,IFBYP(IS)
          BYPQTY(IV,6,IS)=BYPQTY(IV,6,IS)+BYPQTY(IV,IF,IS)
 90   CONTINUE

C****
C  SUM OVER STEPS AND PUT PRODUCTION INTO THE
C  APPROPRIATE ARRAY FOR THE SPECIFIC ENERGY SOURCE.  THE FUEL
C  ORDER IS GIVEN AT THE START OF THIS PROGRAM.
C  DETERMINE THE AMOUNT OF BYPRODUCT THAT GOES TO BSC AND PA.
C  FOR NOW ASSUME EVERYTHING GOES TO BSC.
C****

      DO 96 IV=1,4
        DO 95 IF=1,23
          ENBYPM(IF,IV)=0.0
          BYPBSCM(IF)=0.0
   95   CONTINUE
        DO 92 IF=1,7
          ENBYPI(IF,IV)=0.0
          BYPBSCI(IF)=0.0
   92   CONTINUE
        DO 94 IF=1,9
          ENBYPR(IF,IV)=0.0
          BYPBSCR(IF)=0.0
   94   CONTINUE
   96 CONTINUE
      DO 100 IV=1,4 ! vintages, 4 is total
      DO 100 IS=1,MPASTP
      DO 100 IF=1,IFBYP(IS)
        IFX=IFLOCBY(IF,IS)
        IF(IFX.LE.30) THEN
          ENBYPM(IFX,IV)=ENBYPM(IFX,IV)+BYPQTY(IV,IF,IS)
         IF(IV.EQ.4)BYPBSCM(IFX)=ENBYPM(IFX,IV)
        ELSE
          IF(IFX.LE.40) THEN
            IFY=IFX-30
            ENBYPI(IFY,IV)=ENBYPI(IFY,IV)+BYPQTY(IV,IF,IS)
             IF(IV.EQ.4)BYPBSCI(IFY)=ENBYPI(IFY,IV)
          ELSE
c *** the idea here is that bypqty and enbypr are "produced" via uecs ***
c *** in the pa component.  this code assigns all this byproduct to   ***
c *** the bsc. however, a small amount is assumed to be consumed in   ***
c *** the pa component, so i must be double counting the amount of    ***
c *** renewable byproduct consumption                                 ***
            IFY=IFX-40
            ENBYPR(IFY,IV)=ENBYPR(IFY,IV)+BYPQTY(IV,IF,IS)
             IF(IV.EQ.4)BYPBSCR(IFY)=ENBYPR(IFY,IV)
     1                              -enprqty(ify)
          ENDIF
        ENDIF
  100 CONTINUE

C****
C  ENERGY BYPRODUCT PRODUCTION IS WRITTEN TO DEBUG FILE IF ON.
C****

      IF(IWDBG.EQ.1) THEN
         IF(IOPEN.EQ.1.AND.LSTITER.EQ.1) WRITE(IUNIT1,512)
        DO 150 IF=1,22
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IF,ENBYPM(IF,4)
  150   CONTINUE
        DO 160 IF=1,6
           IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IF,ENBYPI(IF,4)
  160   CONTINUE
        DO 170 IF=1,8
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IF,ENBYPR(IF,4)
  170   CONTINUE
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  512 FORMAT(1X,'PROCESS/ASSEMBLY BYPRODUCT PRODUCTION BY FUEL:')
  513 FORMAT(5X,'FUEL ',I4,F12.2)
  991 FORMAT(3X,'CALBYPROD')

      RETURN
      END

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS STEP CALCULATES THE TOTAL ENERGY CONSUMPTION IN THE PROCESS
C  ASSEMBLY COMPONENT.
C****
      SUBROUTINE CALPATOT
      IMPLICIT NONE
      include(parametr)
      INCLUDE(INDCTRL)
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
      include(ncntrl)
C****
C  DECLARE INTERNAL VARIABLES.
C****

      INTEGER IS,IF,IV,IFX,IFY,IFUEL
      INTEGER CASE
      REAL ASPHALT(5) ! five growth factors corresponding
      REAL GASFEED(5) ! to base oil price and technology : base, frozen, high tech
      REAL LPGFEED(5) ! low oil and high oil cases
      REAL PETROFEED(5)

      DATA ASPHALT/.8,.275,.975,.85,.75/
      DATA GASFEED/.75,.1,.85,.71,1./
      DATA LPGFEED/.95,.35,.95,.99,.8/
      DATA PETROFEED/.95,.35,.95,.99,.8/

C     Case I: Base Oil Price, Base Technology

C     Case II: Base Oil Price, High Technology

C     Case III: Base Oil Price, Frozen Technology

C     Case IV: Low Oil Price, Base Technology

C     Case V:  High Oil Price, Base Technolgy

C ***** LBNL HITECH FLAG *****
      if(wwop.eq.2.and.hitech.eq.0.and.frztech.eq.0) then
        CASE = 1
       elseif(wwop.eq.2.and.hitech.eq.1.and.frztech.eq.0) then
        CASE = 2
       elseif(wwop.eq.2.and.hitech.eq.0.and.frztech.eq.1) then
        CASE = 3
       elseif(wwop.eq.1) then
        CASE = 4
       elseif(wwop.eq.3) then
        CASE = 5
       endif


C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE INTERCEPTS FOR ESTIMATED EQUATION IN 1990.
c  do not call this routine ever again
C****

c         IF(IYR.EQ.IBYR.and.inddir.le.6) THEN
c           CALL CALINTER
c         ENDIF
C****
C  CALCULATE THE ENERGY CONSUMPTION BY VINTAGE IN EACH PROCESS STEP.
c  the first part of this code limits asphalt and feedstock
c  demand increases
C****
      DO 60 IS=1,MPASTP
      DO 60 IFUEL=1,IFMAX(IS)
          ENPQTY(1,IFUEL,IS)=PRODCUR(1,IS)*ENPINT(1,IFUEL,IS)
          ENPQTY(2,IFUEL,IS)=PRODCUR(2,IS)*ENPINT(2,IFUEL,IS)
          ENPQTY(3,IFUEL,IS)=PRODCUR(3,IS)*ENPINT(3,IFUEL,IS)
          ENPQTY(4,IFUEL,IS)=ENPQTY(1,IFUEL,IS)+ENPQTY(2,IFUEL,IS)+
     1                                       ENPQTY(3,IFUEL,IS)
          
        IF(IYR.GT.2000.AND.INDDIR.EQ.6.AND.IFUEL.EQ.6) THEN
          ENPQTY(1,IFUEL,IS)=ENPINT(1,IFUEL,IS)*(PRODZERO(1,IS)+
     1         ASPHALT(CASE)*(PRODCUR(1,IS)-PRODZERO(1,IS)))
          ENPQTY(2,IFUEL,IS)=ENPINT(2,IFUEL,IS)*(PRODZERO(2,IS)+
     1         ASPHALT(CASE)*(PRODCUR(2,IS)-PRODZERO(2,IS)))
          ENPQTY(3,IFUEL,IS)=ENPINT(3,IFUEL,IS)*(PRODZERO(3,IS)+
     1         ASPHALT(CASE)*(PRODCUR(3,IS)-PRODZERO(3,IS)))
          ENPQTY(4,IFUEL,IS)=ENPQTY(1,IFUEL,IS)+ENPQTY(2,IFUEL,IS)+
     1                                       ENPQTY(3,IFUEL,IS)

c  **** this is natural gas feedstocks they move opposite to oil ****
        ELSEIF(IYR.GT.2000.AND.INDDIR.EQ.9.AND.IS.EQ.5.AND.IFUEL.EQ.1)
     1   THEN
          ENPQTY(1,IFUEL,IS)=ENPINT(1,IFUEL,IS)*(PRODZERO(1,IS)+
     1         GASFEED(CASE)*(PRODCUR(1,IS)-PRODZERO(1,IS)))
          ENPQTY(2,IFUEL,IS)=ENPINT(2,IFUEL,IS)*(PRODZERO(2,IS)+
     1         GASFEED(CASE)*(PRODCUR(2,IS)-PRODZERO(2,IS)))
          ENPQTY(3,IFUEL,IS)=ENPINT(3,IFUEL,IS)*(PRODZERO(3,IS)+
     1         GASFEED(CASE)*(PRODCUR(3,IS)-PRODZERO(3,IS)))
          ENPQTY(4,IFUEL,IS)=ENPQTY(1,IFUEL,IS)+ENPQTY(2,IFUEL,IS)+
     1                                       ENPQTY(3,IFUEL,IS)
        ELSEIF(IYR.GT.2000.AND.INDDIR.EQ.9.AND.IS.EQ.5.AND.IFUEL.EQ.2)
     1   THEN
          ENPQTY(1,IFUEL,IS)=ENPINT(1,IFUEL,IS)*(PRODZERO(1,IS)+
     1         LPGFEED(CASE)*(PRODCUR(1,IS)-PRODZERO(1,IS)))
          ENPQTY(2,IFUEL,IS)=ENPINT(2,IFUEL,IS)*(PRODZERO(2,IS)+
     1         LPGFEED(CASE)*(PRODCUR(2,IS)-PRODZERO(2,IS)))
          ENPQTY(3,IFUEL,IS)=ENPINT(3,IFUEL,IS)*(PRODZERO(3,IS)+
     1         LPGFEED(CASE)*(PRODCUR(3,IS)-PRODZERO(3,IS)))
          ENPQTY(4,IFUEL,IS)=ENPQTY(1,IFUEL,IS)+ENPQTY(2,IFUEL,IS)+
     1                                       ENPQTY(3,IFUEL,IS)
        ELSEIF(IYR.GT.2000.AND.INDDIR.EQ.9.AND.IS.EQ.5.AND.IFUEL.EQ.3)
     1   THEN
          ENPQTY(1,IFUEL,IS)=ENPINT(1,IFUEL,IS)*(PRODZERO(1,IS)+
     1         PETROFEED(CASE)*(PRODCUR(1,IS)-PRODZERO(1,IS)))
          ENPQTY(2,IFUEL,IS)=ENPINT(2,IFUEL,IS)*(PRODZERO(2,IS)+
     1         PETROFEED(CASE)*(PRODCUR(2,IS)-PRODZERO(2,IS)))
          ENPQTY(3,IFUEL,IS)=ENPINT(3,IFUEL,IS)*(PRODZERO(3,IS)+
     1         PETROFEED(CASE)*(PRODCUR(3,IS)-PRODZERO(3,IS)))
          ENPQTY(4,IFUEL,IS)=ENPQTY(1,IFUEL,IS)+ENPQTY(2,IFUEL,IS)+
     1                                       ENPQTY(3,IFUEL,IS)
        ENDIF


C  UnDo high tech case
c  the factor is the percentage difference between the target
c  uec and the model uec for ENDYR, normally 2015 or 2020
C ***** LBNL HITECH FLAG *****

         IF(IYR.GT.1998.AND.HITECH.EQ.1) THEN
          DO IV = 1,3
           if(inddir.le.6.and.ifloc(ifuel,is).ne.17) then ! asphalt was not changed

           IF (inddir.eq.1) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.190)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.2) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.3) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.170)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.4) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.200)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.5) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.220)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           IF (inddir.eq.6 .AND. IFUEL.EQ.1) THEN
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.15)*(float(IYR-1998)/float(endyr-1998)))
           ELSE
              ENPINT(IV,IFUEL,IS) = ENPINT(IV,IFUEL,IS) /
     1            (1. + (-0.001)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF
           
        ENDIF

           IF(INDDIR.EQ.14) THEN
            ENPINT(iv,IFUEL,IS) = ENPINT(iv,IFUEL,IS)/
     1      (1. + (-0.13)*(float(IYR-1998)/float(endyr-1998)))
           ENDIF

           IF(INDDIR.EQ.15) THEN
              IF (IFUEL.EQ.1) THEN
                 ENPINT(iv,IFUEL,IS) = ENPINT(iv,IFUEL,IS)/
     1                (1. + (-0.26)*(float(IYR-1998)/float(endyr-1998)))
              ELSE
                 ENPINT(iv,IFUEL,IS) = ENPINT(iv,IFUEL,IS)/
     1                (1. + (-0.20)*(float(IYR-1998)/float(endyr-1998)))               
              ENDIF
           ENDIF
        ENDDO
      ENDIF


   60 CONTINUE


C****
C  CONVERT KWH AND MMBTU TO TRILLION BTU IF IDVAL=1.
C  DO NOT CONVERT IF IDVAL=2.
C****

      IF(IDVAL.EQ.1.OR.IDVAL.EQ.3) THEN
        DO 70 IS=1,MPASTP
        DO 70 IFUEL=1,IFMAX(IS)
c          IFX=IFLOC(IF,IS)
c          IF(IFX.EQ.1.OR.IFX.EQ.2) THEN        !CONVERT KWH TO TBTU
c            DO 85 IV=1,4
c          ENPQTY(IV,IF,IS)=(ENPQTY(IV,IF,IS)*3412.0)/((10**9)*1000.)
c85       CONTINUE
c        ELSE                                !CONVERT MMBTU TO TBTU
             DO 86 IV=1,4
               ENPQTY(IV,IFUEL,IS)=ENPQTY(IV,IFUEL,IS)/1000000.
 86          CONTINUE
c          ENDIF
 70     CONTINUE
      ENDIF

C****
C  SUM UP THE CONSUMPTION OVER THE FUEL TYPES.
C****

      DO 80 IS=1,MPASTP
      DO 80 IV=1,4
        ENPQTY(IV,16,IS)=0.0
        DO 80 IFUEL=1,IFMAX(IS)
          ENPQTY(IV,16,IS)=ENPQTY(IV,16,IS)+ENPQTY(IV,IFUEL,IS)
 80   CONTINUE

C****
C  SUM OVER VINTAGES AND STEPS AND PUT CONSUMPTION INTO THE
C  APPROPRIATE ARRAY FOR THE SPECIFIC ENERGY SOURCE.  THE FUEL
C  ORDER IS GIVEN AT THE START OF THIS PROGRAM, AND THE ARRAYS ARE
C  ENPMQTY FOR THE MAIN FUEL SOURCES, ENPIQTY FOR THE INTERMEDIATE
C  FUEL SOURCES AND ENPRQTY FOR THE RENEWABLE ENERGY SOURCES.
C****

C****
C NET COKE IMPORTS IS CALCULATED AS THE DIFFERENCE BETWEEN
C COKE CONSUMPTION AND COKE PRODUCTION. FOR NOW, COKE IS
C CONSUMED ONLY IN BF/BOF, STEP 6.  COKE IS PRODUCED  IN
C STEP 8. COKE CONSUMPTION IS ACCUMULATED IN THE INTERMEDIATE
C ARRAY.  WHEN YOU HIT IND 27 AND STEP 8 THEN MAKE THE
C CALCULATION.  Note that net imports no longer can be negative.
C
C****

      DO 90 IFUEL=1,23
        ENPMQTY(IFUEL)=0.0
   90 CONTINUE
      DO 92 IFUEL=1,7
        ENPIQTY(IFUEL)=0.0
   92 CONTINUE
      DO 94 IFUEL=1,9
        ENPRQTY(IFUEL)=0.0
   94 CONTINUE
      DO 100 IS=1,MPASTP
      DO 100 IFUEL=1,IFMAX(IS)
        IFX=IFLOC(IFUEL,IS)
        IF(IFX.LE.30) THEN
          ENPMQTY(IFX)=ENPMQTY(IFX)+ENPQTY(4,IFUEL,IS)
        ELSE
          IF(IFX.LE.40) THEN
            IFY=IFX-30
            ENPIQTY(IFY)=ENPIQTY(IFY)+ENPQTY(4,IFUEL,IS)
            IF(INDDIR.EQ.12.AND.IS.EQ.8) THEN


             ENPMQTY(9) = ENPIQTY(6) - (PRODCUR(4,8)*24.8/1000000.)
            ENDIF
          ELSE
            IFY=IFX-40
            ENPRQTY(IFY)=ENPRQTY(IFY)+ENPQTY(4,IFUEL,IS)
          ENDIF
        ENDIF

  100 CONTINUE

C  Call optional routine to adjust primary fuel shares
c  in selected industries to
c  account for changing energy prices.  The first time
c  called, it reads a spreadsheet input file with the coefficients   
c  for logit fuel sharing equations.
      IF(PRICEPA.EQ.1) THEN
        CALL INDPALOG
      ENDIF

C****
C  ENERGY CONSUMPTION IS WRITTEN TO DEBUG FILE IF IWDBG=1.
C****
      IF(IWDBG.EQ.1) THEN
        IF(IOPEN.EQ.1.AND.LSTITER.EQ.1) WRITE(IUNIT1,512)
        DO 150 IFUEL=1,22
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IFUEL,ENPMQTY(IF)
  150   CONTINUE
        DO 160 IFUEL=1,6
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IFUEL,ENPIQTY(IF)
  160   CONTINUE
        DO 170 IFUEL=1,8
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,513) IFUEL,ENPRQTY(IF)
  170   CONTINUE
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  512 FORMAT(1X,'PROCESS/ASSEMBLY CONSUMPTION BY FUEL:')
  513 FORMAT(5X,'FUEL ',I4,F12.2)
  900 FORMAT(1X,'PSTEP,FUEL',I2,I2)
  901 FORMAT(1X,'TPUT,INTENSITY,CONSPTN')
  902 FORMAT(1X,F25.5,2X,F15.6,2X,F25.6)
  903 FORMAT(1X,F25.5,2X,F15.6,2X,F25.6)
  904 FORMAT(1X,'PROD',1X,F15.5)
  991 FORMAT(3X,'CALPATOT')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
      SUBROUTINE INDPALOG
      implicit none
      include(parametr)
      include(ncntrl)
      include(indctrl)
      
      integer do_once/0/
      integer j
      save do_once
      LOGICAL NEW
      CHARACTER*18 FNAME
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR

      CHARACTER*16 RNAME
      INTEGER WKUNIT

      CHARACTER*20 INDNAME_1,INDNAME_2,INDNAME_3,INDNAME_4,INDNAME_5,
     1             INDNAME_6
      INTEGER*2 INDDIR_1(1),INDDIR_2(1),INDDIR_3(1),
     1         INDDIR_4(1),INDDIR_5(1),INDDIR_6(1)

C   FOOD Industry variables
      INTEGER*2 FOODNUMGRP1(1),FOODNUMGRP2(1)
      INTEGER*2 FOODGROUP1(22), FOODGROUP2(22)
      REAL*4    FOODBETA1(2),  FOODBETA2(6)
C   PAPer Industry variables
      INTEGER*2 PAPNUMGRP1(1),PAPNUMGRP2(1)
      INTEGER*2 PAPGROUP1(22), PAPGROUP2(22)
      REAL*4    PAPBETA1(2),  PAPBETA2(5)

C   CHEMical Industry variables
      INTEGER*2 CHEMNUMGRP1(1),CHEMNUMGRP2(1)
      INTEGER*2 CHEMGROUP1(22), CHEMGROUP2(22)
      REAL*4    CHEMBETA1(2),  CHEMBETA2(5)


C   GLASS Industry variables
      INTEGER*2 GLASNUMGRP1(1),GLASNUMGRP2(1)
      INTEGER*2 GLASGROUP1(22), GLASGROUP2(22)
      REAL*4    GLASBETA1(2),  GLASBETA2(6)

C   Cement Industry variables
      INTEGER*2 CMNTNUMGRP1(1),CMNTNUMGRP2(1)
      INTEGER*2 CMNTGROUP1(22), CMNTGROUP2(22)
      REAL*4    CMNTBETA1(2),  CMNTBETA2(5)

C   STELical Industry variables
      INTEGER*2 STELNUMGRP1(1),STELNUMGRP2(1)
      INTEGER*2 STELGROUP1(22), STELGROUP2(22)
      REAL*4    STELBETA1(2),  STELBETA2(3)
      integer   i

      if(do_once.eq.0) then
         do_once=1
         NEW=.FALSE.
         FNAME='INDPALOG'


C  OPEN WORKSHEET FILE USING FILE MANAGER
         WKUNIT = FILE_MGR('O',FNAME,NEW)
       
       
C  CALL SUBROUTINE TO READ ALL DEFINED RANGES FROM WORKSHEET
C  This stores the ranges in a temporary data area that can
c  get overwritten by the next model if they use it.  So all
c  ranges have to be extracted from the temporary area immediately.
         CALL READRNG(WKUNIT)

C  CLOSE WORKSHEET FILE
         WKUNIT = FILE_MGR('C',FNAME,NEW)

C  Copy each range from worksheet data area to variables
c  GETRNGI : Copies an Integer*2 variable from the worksheet
c            data area into the variable.  The variable
c            dimensions are passed as the 3rd,4th,&5th 
c            arguments, (eg, ... 1,1,1).
c            A variable with dimesions of 1,1,1 is a scalar.
c            A variable with dimensions of 26,1,1 is a one-
c            dimensional array with 26 elements.
c  GETRNGR:  Copies a REAL variable from the worksheet
c            data area into the variable.  
C FOOD
         CALL GETRNGI('INDDIR_1        ',INDDIR_1   ,1,1,1)
         CALL GETRNGC('INDNAME_1       ',INDNAME_1  ,1,1,1)

         CALL GETRNGI('FOODNUMGRP1     ',FOODNUMGRP1 ,1,1,1)
         I=FOODNUMGRP1(1)
         CALL GETRNGR('FOODBETA1       ',FOODBETA1   ,i,1,1)
         CALL GETRNGI('FOODGROUP1      ',FOODGROUP1  ,22,1,1)

         CALL GETRNGI('FOODNUMGRP2     ',FOODNUMGRP2 ,1,1,1)
         I=FOODNUMGRP2(1)
         CALL GETRNGR('FOODBETA2       ',FOODBETA2   ,i,1,1)
         CALL GETRNGI('FOODGROUP2      ',FOODGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_1      ',INDDIR_1(1)   
           WRITE(6,1001)'INDNAME_1     ',INDNAME_1  

           WRITE(6,1000)'FOODNUMGRP1   ',FOODNUMGRP1(1)
        WRITE(6,1002)'FOODBETA1     ',(FOODBETA1(J),J=1,FOODNUMGRP1(1))
           WRITE(6,1004)'FOODGROUP1    ',(J,FOODGROUP1(J),J=1,22)

           WRITE(6,1000)'FOODNUMGRP2   ',FOODNUMGRP2(1)
        WRITE(6,1002)'FOODBETA2     ',(FOODBETA2(J),J=1,FOODNUMGRP2(1))       
           WRITE(6,1004)'FOODGROUP2    ',(J,FOODGROUP2(J),J=1,22)
         ENDIF

C PAPER
         CALL GETRNGI('INDDIR_2        ',INDDIR_2   ,1,1,1)
         CALL GETRNGC('INDNAME_2       ',INDNAME_2  ,1,1,1)

         CALL GETRNGI('PAPNUMGRP1      ',PAPNUMGRP1 ,1,1,1)
         I=PAPNUMGRP1(1)
         CALL GETRNGR('PAPBETA1        ',PAPBETA1   ,i,1,1)
         CALL GETRNGI('PAPGROUP1       ',PAPGROUP1  ,22,1,1)

         CALL GETRNGI('PAPNUMGRP2      ',PAPNUMGRP2 ,1,1,1)
         I=PAPNUMGRP2(1)
         CALL GETRNGR('PAPBETA2        ',PAPBETA2   ,i,1,1)
         CALL GETRNGI('PAPGROUP2       ',PAPGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_2        ',INDDIR_2(1)   
           WRITE(6,1001)'INDNAME_2       ',INDNAME_2  

           WRITE(6,1000)'PAPNUMGRP1      ',PAPNUMGRP1(1)
        WRITE(6,1002)'PAPBETA1        ',(PAPBETA1(J),J=1,PAPNUMGRP1(1))       
           WRITE(6,1004)'PAPGROUP1       ',(J,PAPGROUP1(J),J=1,22)

           WRITE(6,1000)'PAPNUMGRP2      ',PAPNUMGRP2(1) 
        WRITE(6,1002)'PAPBETA2        ',(PAPBETA2(J),J=1,PAPNUMGRP2(1))  
           WRITE(6,1004)'PAPGROUP2       ',(J,PAPGROUP2(J),J=1,22)
         ENDIF
1000   FORMAT(1X,A,':',I3)
1001   FORMAT(1X,A,':',A)
1002   FORMAT(1X,A,':',8F10.3)
1004   FORMAT(1X,A/,22(2I4/))

C  Chemicals
         CALL GETRNGI('INDDIR_3        ',INDDIR_3   ,1,1,1)
         CALL GETRNGC('INDNAME_3       ',INDNAME_3  ,1,1,1)

         CALL GETRNGI('CHEMNUMGRP1     ',CHEMNUMGRP1 ,1,1,1)
         I=CHEMNUMGRP1(1)
         CALL GETRNGR('CHEMBETA1       ',CHEMBETA1   ,i,1,1)
         CALL GETRNGI('CHEMGROUP1      ',CHEMGROUP1  ,22,1,1)

         CALL GETRNGI('CHEMNUMGRP2     ',CHEMNUMGRP2 ,1,1,1)
         I=CHEMNUMGRP2(1)
         CALL GETRNGR('CHEMBETA2       ',CHEMBETA2   ,i,1,1)
         CALL GETRNGI('CHEMGROUP2      ',CHEMGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_3      ',INDDIR_3(1)   
           WRITE(6,1001)'INDNAME_3     ',INDNAME_3  

           WRITE(6,1000)'CHEMNUMGRP1   ',CHEMNUMGRP1(1)
        WRITE(6,1002)'CHEMBETA1     ',(CHEMBETA1(J),J=1,CHEMNUMGRP1(1))       
           WRITE(6,1004)'CHEMGROUP1    ',(J,CHEMGROUP1(J),J=1,22)

           WRITE(6,1000)'CHEMNUMGRP2   ',CHEMNUMGRP2(1)
        WRITE(6,1002)'CHEMBETA2     ',(CHEMBETA2(J),J=1,CHEMNUMGRP2(1))
           WRITE(6,1004)'CHEMGROUP2    ',(J,CHEMGROUP2(J),J=1,22)
         ENDIF
C  Glass
         CALL GETRNGI('INDDIR_4        ',INDDIR_4   ,1,1,1)
         CALL GETRNGC('INDNAME_4       ',INDNAME_4  ,1,1,1)

         CALL GETRNGI('GLASNUMGRP1     ',GLASNUMGRP1 ,1,1,1)
         I=GLASNUMGRP1(1)
         CALL GETRNGR('GLASBETA1       ',GLASBETA1   ,i,1,1)
         CALL GETRNGI('GLASGROUP1      ',GLASGROUP1  ,22,1,1)

         CALL GETRNGI('GLASNUMGRP2     ',GLASNUMGRP2 ,1,1,1)
         I=GLASNUMGRP2(1)
         CALL GETRNGR('GLASBETA2       ',GLASBETA2   ,i,1,1)
         CALL GETRNGI('GLASGROUP2      ',GLASGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_4       ',INDDIR_4(1)   
           WRITE(6,1001)'INDNAME_4      ',INDNAME_4  

           WRITE(6,1000)'GLASNUMGRP1    ',GLASNUMGRP1(1)
        WRITE(6,1002)'GLASBETA1      ',(GLASBETA1(J),J=1,GLASNUMGRP1(1))
           WRITE(6,1004)'GLASGROUP1     ',(J,GLASGROUP1(J),J=1,22)

           WRITE(6,1000)'GLASNUMGRP2    ',GLASNUMGRP2(1) 
        WRITE(6,1002)'GLASBETA2      ',(GLASBETA2(J),J=1,GLASNUMGRP2(1))
           WRITE(6,1004)'GLASGROUP2     ',(J,GLASGROUP2(J),J=1,22)
         ENDIF
C Cement
         CALL GETRNGI('INDDIR_5        ',INDDIR_5   ,1,1,1)
         CALL GETRNGC('INDNAME_5       ',INDNAME_5  ,1,1,1)

         CALL GETRNGI('CMNTNUMGRP1     ',CMNTNUMGRP1 ,1,1,1)
         I=CMNTNUMGRP1(1)
         CALL GETRNGR('CMNTBETA1       ',CMNTBETA1   ,i,1,1)
         CALL GETRNGI('CMNTGROUP1      ',CMNTGROUP1  ,22,1,1)

         CALL GETRNGI('CMNTNUMGRP2     ',CMNTNUMGRP2 ,1,1,1)
         I=CMNTNUMGRP2(1)
         CALL GETRNGR('CMNTBETA2       ',CMNTBETA2   ,i,1,1)
         CALL GETRNGI('CMNTGROUP2      ',CMNTGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_5       ',INDDIR_5(1)   
           WRITE(6,1001)'INDNAME_5      ',INDNAME_5  

           WRITE(6,1000)'CMNTNUMGRP1    ',CMNTNUMGRP1(1)
        WRITE(6,1002)'CMNTBETA1      ',(CMNTBETA1(J),J=1,CMNTNUMGRP1(1))
           WRITE(6,1004)'CMNTGROUP1     ',(J,CMNTGROUP1(J),J=1,22)

           WRITE(6,1000)'CMNTNUMGRP2    ',CMNTNUMGRP2(1) 
        WRITE(6,1002)'CMNTBETA2      ',(CMNTBETA2(J),J=1,CMNTNUMGRP2(1))
           WRITE(6,1004)'CMNTGROUP2     ',(J,CMNTGROUP2(J),J=1,22)
         ENDIF
C Steel
         CALL GETRNGI('INDDIR_6        ',INDDIR_6   ,1,1,1)
         CALL GETRNGC('INDNAME_6       ',INDNAME_6  ,1,1,1)

         CALL GETRNGI('STELNUMGRP1     ',STELNUMGRP1 ,1,1,1)
         I=STELNUMGRP1(1)
         CALL GETRNGR('STELBETA1       ',STELBETA1   ,i,1,1)
         CALL GETRNGI('STELGROUP1      ',STELGROUP1  ,22,1,1)

         CALL GETRNGI('STELNUMGRP2     ',STELNUMGRP2 ,1,1,1)
         I=STELNUMGRP2(1)
         CALL GETRNGR('STELBETA2       ',STELBETA2   ,i,1,1)
         CALL GETRNGI('STELGROUP2      ',STELGROUP2  ,22,1,1)

         IF(PRTDBGI.GT.1) THEN
           WRITE(6,1000)'INDDIR_6       ',INDDIR_6(1)   
           WRITE(6,1001)'INDNAME_6      ',INDNAME_6  

           WRITE(6,1000)'STELNUMGRP1    ',STELNUMGRP1(1)
        WRITE(6,1002)'STELBETA1      ',(STELBETA1(J),J=1,STELNUMGRP1(1))
           WRITE(6,1004)'STELGROUP1     ',(J,STELGROUP1(J),J=1,22)

           WRITE(6,1000)'STELNUMGRP2    ',STELNUMGRP2(1) 
        WRITE(6,1002)'STELBETA2      ',(STELBETA2(J),J=1,STELNUMGRP2(1))
           WRITE(6,1004)'STELGROUP2     ',(J,STELGROUP2(J),J=1,22)
         ENDIF
      ENDIF
C Food     
C  Stage 1: ELEC/NONELEC Split       
C  Stage 2:  FOSSIL Fuel Split 
      IF(INDDIR_2(1).EQ.13)INDDIR_2(1)=8
      IF(INDDIR_3(1).EQ.15)INDDIR_3(1)=9
      IF(INDDIR_4(1).EQ.24)INDDIR_4(1)=10
      IF(INDDIR_5(1).EQ.25)INDDIR_5(1)=11
      IF(INDDIR_6(1).EQ.27)INDDIR_6(1)=12
      IF (INDDIR.EQ.INDDIR_1(1)) THEN
       CALL CALPALOG(FOODGROUP1,FOODBETA1,FOODNUMGRP1,INDNAME_1,1)
       CALL CALPALOG(FOODGROUP2,FOODBETA2,FOODNUMGRP2,INDNAME_1,2)
      ENDIF
C PAPER
      IF (INDDIR.EQ.INDDIR_2(1)) THEN
       CALL CALPALOG(PAPGROUP1,PAPBETA1,PAPNUMGRP1,INDNAME_2,1)
       CALL CALPALOG(PAPGROUP2,PAPBETA2,PAPNUMGRP2,INDNAME_2,2)
      ENDIF
C Chemicals
      IF (INDDIR.EQ.INDDIR_3(1)) THEN
       CALL CALPALOG(CHEMGROUP1,CHEMBETA1,CHEMNUMGRP1,INDNAME_3,1)
       CALL CALPALOG(CHEMGROUP2,CHEMBETA2,CHEMNUMGRP2,INDNAME_3,2)
      ENDIF
C GLASS
      IF (INDDIR.EQ.INDDIR_4(1)) THEN
       CALL CALPALOG(GLASGROUP1,GLASBETA1,GLASNUMGRP1,INDNAME_4,1)
       CALL CALPALOG(GLASGROUP2,GLASBETA2,GLASNUMGRP2,INDNAME_4,2)
      ENDIF
C Cement
      IF (INDDIR.EQ.INDDIR_5(1)) THEN
       CALL CALPALOG(CMNTGROUP1,CMNTBETA1,CMNTNUMGRP1,INDNAME_5,1)
       CALL CALPALOG(CMNTGROUP2,CMNTBETA2,CMNTNUMGRP2,INDNAME_5,2)
      ENDIF
C Steel
      IF (INDDIR.EQ.INDDIR_6(1)) THEN
       CALL CALPALOG(STELGROUP1,STELBETA1,STELNUMGRP1,INDNAME_6,1)
       CALL CALPALOG(STELGROUP2,STELBETA2,STELNUMGRP2,INDNAME_6,2)
      ENDIF
      RETURN
      END
c================================================================================
C  Reads Spreadsheet input file containing price sensitivity coefficients
c  for selected Process/Assembly Industries.  Calls routine to reallocate
c  fuel shares based on changes in market conditions.
C======================================================================      
      SUBROUTINE CALPALOG(GROUP,BETA,NUMGRP,NAMEIND,ISTAGE)
      IMPLICIT NONE
      INTEGER*2 GROUP(22),NUMGRP(1)
      REAL*4 BETA(NUMGRP(1))
      CHARACTER*20 NAMEIND
      INTEGER I,IF,ISTAGE
      include(parametr)
      include(ncntrl)
      INCLUDE(INDCTRL)     
      INCLUDE(INDPA)
      INCLUDE(INDMACRO)
C LOCAL
      INTEGER MAX_LOGIT_GRPS
      PARAMETER(MAX_LOGIT_GRPS=22)
      REAL*4 DEFLTSHR(MAX_LOGIT_GRPS)
      REAL*4 BASEPRC(MAX_LOGIT_GRPS)
      REAL*4 BASEQTY(MAX_LOGIT_GRPS)
      REAL*4 CURSHR(MAX_LOGIT_GRPS)
      REAL*4 CURPRC(MAX_LOGIT_GRPS)
      REAL*4 CURQTY(MAX_LOGIT_GRPS)
      REAL*4 NEWQTY(MAX_LOGIT_GRPS)
      REAL*4 NEWSHR(MAX_LOGIT_GRPS)

      REAL*4 PRCRAT(MAX_LOGIT_GRPS)
      REAL*4 BASEQSUM,CURQSUM
      REAL*4 BASEREV,CURREV
      REAL*4 TERM(MAX_LOGIT_GRPS),SUMTERMS
      REAL*4 NEW_ENPMQTY(22)
C LOCAL BUT SAVED 
      REAL*4 QTYBASE(22,5,40)
      REAL*4 PRCBASE(22,5,40)
      SAVE QTYBASE,PRCBASE
C      
      CHARACTER*20 FUELNAME(22)

      FUELNAME(1)='ELECTRICITY '
      FUELNAME(2)='GENERATION'
      FUELNAME(3)='NAT GAS CORE '
      FUELNAME(4)='NAT GAS NONCORE'
      FUELNAME(5)='NAT GAS FEEDSTOCK'
      FUELNAME(6)='NAT GAS LEASE & PLANT'
      FUELNAME(7)='STEAM COAL'
      FUELNAME(8)='COKING COAL'
      FUELNAME(9)='NET COKE IMPORTS'
      FUELNAME(10)='RESIDUAL OIL'
      FUELNAME(11)='DISTILLATE OIL'
      FUELNAME(12)='LPGS, HEAT AND POWER'
      FUELNAME(13)='LPGS, FEEDSTOCKS'
      FUELNAME(14)='MOTOR GASOLINE'
      FUELNAME(15)='STILL GAS'
      FUELNAME(16)='PETROLEUM COKE'
      FUELNAME(17)='ASPHALT & ROAD OIL'
      FUELNAME(18)='LUBES & WAXES'
      FUELNAME(19)='PETROCHEM FEEDSTOCKS'
      FUELNAME(20)='KEROSENE'
      FUELNAME(21)='OTHER OIL FEEDSTOCKS'
      FUELNAME(22)='OTHER PETROLEUM'

C  When passing through up through 1996, just grab the base year
c  quantity and price for 1996 and retain for future use
c  in deriving the price trend.


      IF(CURIYR.LE.(1995-BASEYR+1)) THEN
         DO IF=1,22
           QTYBASE(IF,INDREG,INDDIR)=ENPMQTY(IF)
           PRCBASE(IF,INDREG,INDDIR)=PRCX(IF,INDREG)
         ENDDO
         RETURN
      ENDIF   
 
      DO I=1,MAX_LOGIT_GRPS
        BASEPRC(I)=0
        BASEQTY(I)=0
        CURQTY(I)=0.
        CURPRC(I)=0.     
        CURSHR(I)=0.     
        NEWSHR(I)=0.
        NEWQTY(I)=0.
        DEFLTSHR(I)=0.
        PRCRAT(I)=1.
      ENDDO
      BASEQSUM=0.0
      CURQSUM=0.0
      DO IF = 1,22
         NEW_ENPMQTY(IF)=ENPMQTY(IF)
      ENDDO
C       
      
C FOR EACH GROUP MEMBER, DERIVE ITS BASE YEAR QTY, BASE YEAR PRICE,
C CURRENT YEAR QUANTITY, CURRENT YEAR PRICE, AND THE "DEFAULT"
C CURRENT YEAR QTY SHARE.  THE IDEA IS TO REVISE THIS DEFAULT SHARE ONLY
C IF RELATIVE PRICES HAVE CHANGED, AND TO DO SO BY RESHARING USING A LOGIT
C EQUATION.   THAT IS, THE PROCESS ASSEMBLY ROUTINE HAS ALREADY 
C DETERMINED WHAT THE PRODUCTION-BASED FUEL REQ'TS ARE, ASSUMING NO
C CHANGE IN BEHAVIOR IN RESPONSE TO RELATIVE PRICE CHANGES.  THIS ROUTINE
C ADJUSTS THOSE FUEL REQT'S IN AGGREGATE  (IE, ACROSS PROCESS STEPS AND 
C VINTAGES) TO REFLECT POTENTIAL MARKET RESPONSE.   FOR ACCOUNTING 
C and Reporting CONSISTENCY, THE REVISED FUEL  SHARES ARE THEN APPLIED TO THE 
C DISAGGREGATED (STEP AND VINTAGE) FUEL ARRAYS.
C 

c  ACCUMULATE (OVER 22 POSSIBLE FUELS) the following:
C    BASEQTY: BASE YEAR QUANTITY
C    BASEREV: BASE YEAR REVENUE    (IE, P*Q)
C    CURQTY:  CURRENT YEAR QUANTITY, DEFAULT
C    CURREV:  CURRENT YEAR REVENUE (IE, P*Q), DEFAULT
C
C    BASEPRC: BASE YEAR PRICE
C    CURPRC:  CURRENT-YEAR PRICE
C    DEFLTSHR: DEFAULT, CURRENT-YEAR QUANTITY SHARE
C    PRCRAT:  RATIO OF CURRENT-YEAR TO BASE-YEAR PRICE

      DO I=1,NUMGRP(1)
         BASEREV=0.
         CURREV=0.
         DO IF=1,22
            IF(GROUP(IF).EQ.I) THEN
              BASEQTY(I)=BASEQTY(I)+ QTYBASE(IF,INDREG,INDDIR)
              BASEREV   =BASEREV   +(PRCBASE(IF,INDREG,INDDIR)*
     1                               QTYBASE(IF,INDREG,INDDIR))
              CURQTY(I) =CURQTY(I) + ENPMQTY(IF)
              CURREV    =CURREV    +(ENPMQTY(IF)*PRCX(IF,INDREG))
            ENDIF            
         ENDDO
         IF(BASEREV.GT.0.0) THEN
            BASEPRC(I)=BASEREV/BASEQTY(I)
         ENDIF
         IF(CURREV .GT.0.0) THEN
            CURPRC(I)=CURREV/CURQTY(I)
         ENDIF
         IF(BASEPRC(I).GT.0.) THEN
           PRCRAT(I)=MIN(2.0,CURPRC(I)/BASEPRC(I))
         ENDIF
         BASEQSUM=BASEQSUM+BASEQTY(I)
         CURQSUM=CURQSUM+CURQTY(I)
      ENDDO

C  CALCULATE THE NUMERATOR TERMS FOR THE LOGIT.  THE SUM OF EACH 
C  POSSIBLE NUMERATOR TERM IS THE DENOMINATOR:

C (NOTE: NEWSHR WILL EQUAL DEFLTSHR ONLY IF PRCRAT=1. AND ALPHA=-BETA )
      SUMTERMS=0.0
      DO I=1,NUMGRP(1)
         IF(CURQSUM.GT.0.0) THEN
            DEFLTSHR(I)=CURQTY(I)/CURQSUM
         ENDIF
         TERM(I)=DEFLTSHR(I)*EXP(BETA(I)-BETA(I)*PRCRAT(I))   ! LOGIT EQN, PART 1
         SUMTERMS=SUMTERMS+TERM(I)
      ENDDO

C  ESTABLISH THE REVISED FUEL SHARES USING THE LOGIT TERMS FROM ABOVE

      DO I=1,NUMGRP(1)
         IF(SUMTERMS.GT.0.0) THEN
            NEWSHR(I)=TERM(I)/SUMTERMS                        ! LOGIT EQN, PART 2
          ENDIF
      ENDDO        

      DO I=1,NUMGRP(1)
         NEWQTY(I)=CURQSUM*NEWSHR(I)
         DO IF=1,22
            IF(GROUP(IF).EQ.I.AND.CURQTY(I).GT. 0.0001) THEN
              NEW_ENPMQTY(IF)=NEWQTY(I)*(ENPMQTY(IF)/CURQTY(I))
            ENDIF            
         ENDDO
      ENDDO

      IF(PRTDBGI.GE.2) THEN  
C WRITE IT OUT
        write(6,'(//1x,a/1x,a,i2,a,i1)') 'Process Assembly Logit ',
     1                 nameind//' Stage ',istage,' Region ',indreg
        WRITE(6,100)
        DO IF=1,22
          IF(GROUP(IF).GT.0)
     1    WRITE(6,101) IF,FUELNAME(IF),GROUP(IF),
     1    PRCBASE(IF,INDREG,INDDIR),QTYBASE(IF,INDREG,INDDIR),
     1    PRCX(IF,INDREG),          ENPMQTY(IF),NEW_ENPMQTY(IF)
        ENDDO
        WRITE(6,200)
        DO I=1,NUMGRP(1)
          WRITE(6,201) I,BASEPRC(I),BASEQTY(I),
     1                   CURPRC(I), CURQTY(I), DEFLTSHR(I), 
     1                   PRCRAT(I), NEWQTY(I), NEWSHR(I)
        ENDDO 
      ENDIF
100   FORMAT(/1X,'   IF     FUELNAME GROUP',
     1 '   PRCBASE   QTYBASE    PRCX   ENPMQTY NEW_ENPMQTY'/
     1 1X,'===== ============ =====',
     1 '   =======   ======= =======   ======= ===========')
101   FORMAT(1X,I5,1x,A12,I6,F10.4,F10.4,F8.4,F10.4,F12.4)
200   FORMAT(1X,'GROUP BASEPRC   BASEQTY',
     1          '    CURPRC    CURQTY DEFLTSHR',
     2           '   PRCRAT    NEWQTY  NEWSHR'/
     3       1X,'===== =======   =======',
     1          '   =======   ======= ========',
     2          '   ======    ======  ======')
201   FORMAT(1X,I5,F8.4,F10.4,F10.4,F10.4,F8.4,F10.4,F10.4,F8.4)

C  REPLACE ENPMQTY WITH NEW_ENPMQTY

      DO IF=1,22
         ENPMQTY(IF)=NEW_ENPMQTY(IF)
      ENDDO
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S UECS BASED ON
C  CONSERVATION/TECHNOLOGICAL SAVINGS CURVES.
C  THE OLD,MID AND NEW UECS ARE RECALCULATED.
C  EQUATION USED: TYPE 2 (ECONOMETRIC ESTIMATED EQUATION)
C****
      SUBROUTINE CALINTER
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IF,IS,IFX,IT
      REAL WPRC(11),TEMP(15,30),XTEMP

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C    CALCULATE INTERCEPTS FOR EQUATION TYPE 2.
C****

      DO IS=1,MPASTP
        DO IF=1,IFMAX(IS)
          IF(ITYPE(IF,IS).EQ.2) THEN

C  ASSIGN PRICE VARIABLES.

            IFX=IFLOC(IF,IS)
            WPRC(1)=PRCX(IFX,INDREG)                   !OWN
            WPRC(2)=PRCX(1,INDREG)                     !ELECTRICITY
            WPRC(3)=PRCX(3,INDREG)                     !NATURAL GAS
            WPRC(4)=PRCX(7,INDREG)                     !STEAM COAL
            IF(INDDIR.LT.7) THEN
              WPRC(5)=PRCX(10,INDREG)                  !OIL
            ELSE
              WPRC(5)=PRCX(11,INDREG)
            ENDIF
            WPRC(6)=PRCX(14,INDREG)                    !MOTOR GAS
            WPRC(7)=PRCX(17,INDREG)                    !ASPHALT
            WPRC(8)=1.0                                !OTHER
            IF(INDDIR.NE.9) THEN
                WPRC(9)=PRCX(12,INDREG)     !LPG FOR HEAT AND POWER
            ELSE
                WPRC(9)=PRCX(13,INDREG)     !LPG FOR FEEDSTOCKS
            ENDIF
            WPRC(10)=PRCX(11,INDREG)          !DISTILLATES
            WPRC(11)=PRCX(10,INDREG)          !RESIDUALS

C  CALCULATE PRICE MULTIPLIERS.

           TEMP(IF,IS)=1.0
           DO IT=1,11
            IF(WPRC(IT).GT.0.0.AND.
     1       BELAS(1,IF,IS,IT).NE.0.0) THEN
             TEMP(IF,IS)=TEMP(IF,IS)*(WPRC(IT)**BELAS(1,IF,IS,IT))
            ENDIF
           ENDDO

C  CALCULATE INTERCEPTS.


            IF(CUMOUT88.NE.0.0) THEN
               XTEMP=CUMOUT88**BCSC(1,IF,IS)*TEMP(IF,IS)
            ENDIF
            IF(XTEMP.NE.0.0.AND.CUMOUT88.NE.0.0) THEN
              EINTER(1,IF,IS)=ENPINT(1,IF,IS)/
     1                       (CUMOUT88**BCSC(1,IF,IS)*
     1                       TEMP(IF,IS))
            ENDIF
            EINTER(3,IF,IS)=EINTER(1,IF,IS)
         ENDIF
        ENDDO
      ENDDO

C****
C  FORMAT STATEMENTS.
C****
  991 FORMAT(3X,'CALINTER')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES THIS YEAR'S ENERGY EFFICIENCY
C  IN THE BUILDINGS COMPONENT (LIGHTING AND HVAC).
C****
      SUBROUTINE CALBLD
      IMPLICIT NONE
      INCLUDE (PARAMETR)
      INCLUDE (NCNTRL)
      INCLUDE (COMMREP)   ! REPORTING DATA FROM THE COMMERCIAL MODULE
      INCLUDE(INDALL)

      DIMENSION PTRANS(3)
      DIMENSION LEFFEL(26)
      DIMENSION HEFFEL(26)
      DIMENSION HEFFNG(26)
      DIMENSION HEFFST(26)
      REAL LEFFEL,HEFFEL,HEFFNG,HEFFST,LEFFL,HEFFL,HEFFG
      INTEGER IF,IFF,J,PTRANS

C****
C  FOR NOW, USE AEO93 COMMERCIAL BUILDING EFFICIENCIES FORECASTS.
C****

      DATA PTRANS/1,3,31/

C****
C     EFFICIENCY NUMBERS FROM COMMERCIAL AEO93 FOR LIGHTING.
C****

        DATA LEFFEL/1.0,1.0,.97,1.0,.99,1.0,1.0,.99,1.0,.99,.99,
     1 .99,.99,.98,.98,.98,.98,.98,.98,.98,.98,.98,.98,.98,
     2 .98,.98/

C****
C     EFFICIENCY NUMBERS FROM COMMERCIAL AEO93 FOR HVAC.
C****

C  ELECTRICITY  (WHY INCREASING?)
       DATA HEFFEL/1.0,1.0,1.01,1.01,.99,1.01,1.01,.99,1.01,1.01,.99,
     1 1.01,.99,.99,1.00,.99,.99,.99,.99,.99,.99,.99,.99,.99,
     2 .99,.99/
C  NATURAL GAS
       DATA HEFFNG/1.0,1.0,1.05,1.04,1.0,1.0,1.0,1.0,1.0,1.0,1.04,
     1 1.0,1.0,1.0,1.04,1.0,1.0,1.0,1.03,1.0,1.0,1.0,1.0,1.0,
     2 1.0,1.0/
C  STEAM  (ASSUME NO CHANGE IN EFFICIENCY)
       DATA HEFFST/1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
     1 1/

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE THIS YEAR'S ENERGY ENTENSITIES.
C****

       J=IYR-1989


C****
C    LIGHTING:
C****

       ENBINT(1,1)=ENBINT(1,1)*LEFFEL(J)

C****
C    HVAC:
C****

       DO 50 IF=1,3
         IFF=PTRANS(IF)
         IF(IFF.EQ.1)
     1     ENBINT(2,IF)=ENBINT(2,IF)*HEFFEL(J)
         IF(IFF.EQ.3)
     1     ENBINT(2,IF)=ENBINT(2,IF)*HEFFNG(J)
         IF(IFF.EQ.31)
     1     ENBINT(2,IF)=ENBINT(2,IF)*HEFFST(J)
   50  CONTINUE

C****
C    FORMAT STATEMENTS
C****

  991 FORMAT(3X,'CALBLD')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C THIS SUBROUTINE CALCULATES TOTAL ENERGY CONSUMPTION FOR
C  THE BUILDINGS COMPONENT.
C****
      SUBROUTINE CALBTOT
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IS,IF

C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE ENERGY CONSUMPTION FOR LIGHTING AND HVAC.
C****

      DO 70 IS=1,2
      DO 70 IF=1,3
        ENBQTY(IS,IF)=EMPLX(INDDIR,INDREG)*ENBINT(IS,IF)
   70 CONTINUE
      DO 80 IF=1,3
        ENBQTY(3,IF)=ENBQTY(1,IF)+ENBQTY(2,IF)
   80 CONTINUE

C****
C  WRITE CONSUMPTION TO DEBUG FILE, IF ON.
C****

      IF(IWDBG.EQ.1) THEN
        IF(IOPEN.EQ.1.AND.LSTITER.EQ.1) WRITE(IUNIT1,974)
        DO 150 IF=1,3
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,973) IF,(ENBQTY(IS,IF),IS=1,3)
  150   CONTINUE
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  973 FORMAT(5X,'FUEL ',I4,3F12.2)
  974 FORMAT(1X,'BUILDINGS CONSUMPTION BY FUEL:')
  991 FORMAT(3X,'CALBTOT')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C THIS SUBROUTINE CALCULATES ELECTRICITY GENERATION FOR OWN
C USE AND SALES TO THE GRID.  IT ALSO CALCULATES STEAM USED
C  FOR COGENERATION.
C****
      SUBROUTINE CALGEN 
      IMPLICIT NONE
      INCLUDE(INDALL)
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)

      COMMON/COGSHR/CAPSHR(9,6,2),GRDSHRG(4,15),prime(11,32,15,4)

      REAL CAPSHR,GRDSHRG
C****
      INTEGER IT
      INTEGER MY,YR,JR,I,J,K,L,M,n
      REAL TEMP(11),GENLAG
      REAL AVGUTL(10)
      REAL GNTOTAL(6) ! each industry's us total for each fuel
      REAL GTSHR(4),ICSHR(4),STSHR(4)
      real cinter(15,4,6) ! industry, region, fuel (year not required)
      real shgen(9,9,15,6,4) ! division, year (98), inddir, fuel, prime mover
      real prime ! division, year, inddir, prime mover
      real stemcurlag
      integer pm,fuel,div

c ***********************************************
c *** note that the fuel order for sicgen is: ***
c *** coal, oil, gas, wood, other, msw        ***
c ***********************************************

C SHARES FOR COGEN CAPACITY AND GENERATION
       DATA GTSHR/0.26,0.07,0.37,0.47/
       DATA ICSHR/0.02,0.003,0.001,0.01/
       DATA STSHR/0.72,0.927,0.63,0.52/


C****
C  WRITE SUBROUTINE TRACE, IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)


C****
C  IF UTILIZATION RATE IS MISSING USE THE AVERAGE
C  UTILIZATION RATE FROM 1992 EIA-867
C****
       DATA AVGUTL/.6750,.6700,.6200,0.0,0.0,.4766,
     1    .6270,0.0,0.0,.6995/
       IF((IYR-1989).GT.MAXCOGYR) THEN
         AVGUTL(2) = .6500
       ENDIF

C***
        DO J = 1,4   ! by 3 prime movers + hydro
         ELSALE(J) = 0.0
         ELOWN(J) = 0.0
        ENDDO
       
       YR = IYR - 1989


C****
C  TOTAL STEAM DEMAND FROM THE BLD AND PA COMPONENTS.
C  IN 1990, WE READ THIS QUANTITY FROM THE ENPROD FILE
C****

      STEMCUR=ENBQTY(2,3)+ENPIQTY(1)


C***
c   use cal_ei867 to
C   calculate generation and capacity from the ei867 files
C***

      CALL CAL_EI867 ! calculates generation from planned ei867 units
C***
C   calculate total ei-867 generation to calibrate industrial generation
C***
C****
C  TOTAL ELECTRICITY GENERATION IS CALCULATED.
C****
       IF(INDREG.EQ.1) THEN
          L = 1
          M = 2
       ELSE IF(INDREG.EQ.2) THEN
          L = 3
          M = 4
       ELSE IF(INDREG.EQ.3) THEN
          L = 5
          M = 7
       ELSE IF(INDREG.EQ.4) THEN
          L = 8
          M = 9
       ENDIF
c ***  set elown and elsale to zero for each new region ***c
       DO pm = 1,4 
        ELOWN(pm)  =  0.0
        ELSALE(pm) =  0.0
       ENDDO

      IF(indreg.eq.1.and.indnum.eq.1.and.
     1   IbYR.eq.1.and.fstiter.eq.1) THEN
       do div=1,9
        do n=1,9
         do k=1,15
          do fuel=1,6
           do pm=1,4
            shgen(div,n,k,fuel,pm)=0.0
           enddo
          enddo
         enddo
        enddo
       enddo
      endif

c     if(indreg.eq.1) then
         do pm=1,4
          gntotal(pm) = 0.0
         enddo
c     endif 

      IF(IYR.LE.(maxplan+1989)) THEN
       DO I = L,M
         do pm =1,4
        DO fuel= 1,6
         GNTOTAL(pm) = GNTOTAL(pm) +
     1    SICGEN(I,curiyr,INDDIR,fuel,pm,3) * 3412.0/10**6
         ENDDO
        ENDDO
        enddo
       ENDIF
      IF(IYR.LE.(maxplan+1989)) THEN
         do i=l,m
        do fuel=1,6
          do pm=1,4
         if(gntotal(pm).gt.0.) then
           shgen(i,curiyr,inddir,fuel,pm)= ! each div's share of the region fuel total
     1    (3412./10**6)*sicgen(i,curiyr,inddir,fuel,pm,3)/gntotal(pm)
         endif
          enddo
        enddo
         enddo
      endif

C    CALCULATE FIRST THE INTERCEPT, IF before 1998
C****
c **** note that gsteam is written to the binary after changing     ****
c **** it in the first year only                                    ****
c **********************************************************************
       IF (IYR.LE.(maxplan+1989)) THEN
        IF(STEMCUR.GT.0.0) THEN
          TEMP(11)=(STEMCUR**GSTEAM)
        ELSE
          TEMP(11)=0.0
        ENDIF
       do pm=1,4
        IF(GNTOTAL(pm).GT.0.0.AND.TEMP(11).GT.0.0) THEN
          cinter(inddir,indreg,pm)=log(gntotal(pm)/temp(11)) ! recalculates every year
        ELSE                                         ! only the 1997 values are kept
         cinter(inddir,indreg,pm)=0.0
        ENDIF
        if (cinter(inddir,indreg,pm).ne.0.0) then
          ELGEN(pm)=(EXP(cINTER(inddir,indreg,pm)))
     1                *(STEMCUR**GSTEAM)
        else
          elgen(pm)=0.0
        endif
       enddo
       ENDIF
C****
C     After 1997, use cinter to 
C    CALCULATE ELECTRICITY GENERATION FOR THE INDUSTRY.
C****

      if(iyr.gt.(maxplan+1989)) then ! this ends at label 100
      IF(STEMCUR.LE.0.0) THEN
        TEMP(11)=0.0
      ELSE
        TEMP(11)=(STEMCUR**GSTEAM)
      ENDIF
       do pm=1,4
      IF(TEMP(11).GT.0.0.and.cinter(inddir,indreg,pm).ne.0.0)THEN
        ELGEN(pm)=(EXP(cINTER(inddir,indreg,pm)))*(STEMCUR**GSTEAM)

C ***** LBNL --- INCREASING GAS COGENERATION BY 215 TWh -- 35GW @ 70% Capacity Factor 
        IF (PM.EQ.2) THEN
C         OPEN(1,FILE='cogendump',STATUS='old')
C         WRITE(1,*)'YR is ',IYR,'--BASELINE COGEN IS ',ELGEN(2)
            IF ((IYR.GE.2001) .AND. (IYR.LT.2010)) THEN
               ELGEN(pm) = ELGEN(pm) * (IYR-1999.0) / 10.0 * 6.0 
            ELSE IF (IYR.GE.2010) THEN
               ELGEN(pm) = ELGEN(pm) * 6.0
            ENDIF
C         WRITE(1,*)'            --MODIFIED COGEN IS ',ELGEN(2)
C         CLOSE(1)
         ENDIF
C ***** LBNL END *****      
       ELSE
        ELGEN(pm)=0.0
      ENDIF
       enddo
        do pm=1,4
         do i=l,m
          do fuel=1,6
            sicgen(i,curiyr,inddir,fuel,pm,3)=
     1        shgen(i,8,inddir,fuel,pm)*elgen(pm)/   ! use the value from 1997
     1        (3412./10**6)
          enddo
         enddo
        enddo
ccc  we  have generation by pm and fuel in sicgen   ccc
ccc  to get the implied capacity we need to add up     ***
c**  the total generation by each pm and then let      ***
c**  pm capacity grow at the same rate                 ***
***  or as here use utilization rates                  ***
      do pm=1,4
        do fuel=1,6
         do i=l,m
            prime(i,curiyr,inddir,pm)=0.0
         enddo
        enddo
       enddo
      do pm=1,4
        do fuel=1,6
         do i=l,m
            prime(i,curiyr,inddir,pm)=prime(i,curiyr,inddir,pm)+
     1      sicgen(i,curiyr,inddir,fuel,pm,3)
         enddo
        enddo
       enddo
          do i=l,m
           do pm=1,4
            if (sicutil(i,6,inddir,pm).gt.0) then
            cap867(i,curiyr,inddir,pm) = 1000.*
     1        prime(i,curiyr,inddir,pm)/
     1       (sicutil(i,6,inddir,pm)*8766.)
            endif
           enddo
          enddo

100   endif


C****
C    CALCULATE TOTAL ELECTRICITY GENERATION BY PRIME MOVER.
C      1=INTERNAL COMBUSTION ENGINE
C      2=COMBUSTION TURBINE
C      3=STEAM TURBINE
C      4=RENEWABLES
C****
c       DO IT=1,3
c         IF(IT.EQ.1) ELGEN(IT)=ELGEN(5)*ICSHR(INDREG)
c         IF(IT.EQ.2) ELGEN(IT)=ELGEN(5)*GTSHR(INDREG)
c         IF(IT.EQ.3) ELGEN(IT)=ELGEN(5)*STSHR(INDREG)
c       ENDDO
C****
C       CALCULATE TOTAL CAPACITY BY PRIME MOVER
C***
       IF(IYR.LE.(MAXCOGYR+1989)) THEN
        CALL CALCGSH ! calculate cogen shares
       ENDIF



C********
C     CALCULATE TOTAL GENERATION OWN/SALES, TOTAL CAPACITY
C     BY prime mover
C********
       DO pm = 1,4 
        ELOWN(pm)  =  ELGEN(pm)*(1-GRDSHRG(INDREG,INDDIR))
        ELSALE(pm) =  ELGEN(pm)*GRDSHRG(INDREG,INDDIR)
       ENDDO



C****
C  FORMAT STATEMENTS.
C****

  900 FORMAT(1X,'COGEN',9F10.1)
  901 FORMAT(1X,'COGEN',7F10.3)
  991 FORMAT(3X,'CALGEN')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C THIS SUBROUTINE CALCULATES THIS YEAR'S BOILER FUEL SHARES.
C THE FUELS INCLUDED HERE ARE THE PURCHASED FUELS ONLY, THAT
C IS, NO BYPRODUCT FUELS.
C****

      SUBROUTINE CALBSC
      IMPLICIT NONE
      INCLUDE(INDALL)

      REAL ALPHA,W(3)
      REAL OILSHARE,TSHR
      REAL LSUM
      INTEGER I,IF,IFF

C****
C  WRITE SUBROUTINE TRACE IF ON.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)


C******
C     ASSIGN PRICES AND COEFFICIENTS TO DUMMY VARIABLES
C   W1=>GAS,W2=>COAL,W3=>OIL
C******


       IF(IYR.EQ.1991) THEN ! COMPUTE SHARES OF OIL FUELS IN BOILERS
          OILSHARE = 0.0
          DO IF = 1,IFSMAX

           IF(IFSLOC(IF).EQ.10.OR.IFSLOC(IF).EQ.11.OR.IFSLOC(IF)
     1       .EQ.12.OR.IFSLOC(IF).EQ.14.OR.IFSLOC(IF).EQ.15.OR.
     1        IFSLOC(IF).EQ.16.OR.IFSLOC(IF).EQ.20.OR.
     1        IFSLOC(IF).EQ.22) THEN

              OILSHARE = OILSHARE + BSSHRLAG(IF)


            ENDIF
          ENDDO

          DO IF = 1,IFSMAX

            IF(IFSLOC(IF).EQ.10.OR.IFSLOC(IF).EQ.11.OR.IFSLOC(IF)
     1       .EQ.12.OR.IFSLOC(IF).EQ.14.OR.IFSLOC(IF).EQ.15.
     1       OR.IFSLOC(IF).EQ.16.OR.IFSLOC(IF).EQ.20.OR.
     1       IFSLOC(IF).EQ.22) THEN

             IF (OILSHARE.GT.0.0) THEN
                BSFUELSHR(INDDIR,INDREG,IF) = BSSHRLAG(IF)/OILSHARE
             ENDIF

            ENDIF
          ENDDO
       ENDIF


       W(1) = PRCX(4,INDREG)/PRCX90(1,INDREG) ! indexed price of gas (1990 = 1)
       W(2) = PRCX(7,INDREG)/PRCX90(2,INDREG) ! indexed price of coal
       W(3) = PRCX(10,INDREG)/PRCX90(3,INDREG)! indexed price of residual fuel
       ALPHA = TLBSHR(INDDIR,INDREG,1)
       LSUM = 0.0
       DO I = 1,3
          LSUM = LSUM +  (W(I)**ALPHA)*TLBSHR(INDDIR,INDREG,I+1)
       ENDDO

C
      DO IF=1,IFSMAX

       IF(IFSLOC(IF).EQ.10.OR.IFSLOC(IF).EQ.11.OR.IFSLOC(IF)
     1   .EQ.12.OR.IFSLOC(IF).EQ.14.OR.IFSLOC(IF).EQ.15.
     1   OR.IFSLOC(IF).EQ.16.OR.IFSLOC(IF).EQ.20.OR.
     1   IFSLOC(IF).EQ.22) THEN

         IF(LSUM.GT.0.0)
     1    BSSHR(IF) = ((W(3)**ALPHA)*TLBSHR(INDDIR,INDREG,4)/LSUM)*
     1                      BSFUELSHR(INDDIR,INDREG,IF) !OIL SHARE

         ENDIF


          IF(IFSLOC(IF).EQ.4) THEN
           IF(LSUM.GT.0.0)
     1       BSSHR(IF) = (W(1)**ALPHA)*TLBSHR(INDDIR,INDREG,2)/LSUM ! GAS SHARE
           ENDIF


         IF(IFSLOC(IF).EQ.7) THEN
           IF(LSUM.GT.0.0)
     1       BSSHR(IF) = (W(2)**ALPHA)*TLBSHR(INDDIR,INDREG,3)/LSUM ! COAL SHARE
           ENDIF

      ENDDO
     

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'CALBSC')
      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES TOTAL FUEL CONSUMPTION IN THE
C  BOILER/STEAM COGENERATION COMPONENT.
C****
      SUBROUTINE CALSTOT
      IMPLICIT NONE
      INCLUDE(INDALL)

      COMMON/COGSHR/CAPSHR(9,6,2),GRDSHRG(4,15),prime(11,32,15,4)

      REAL CAPSHR,GRDSHRG
C****
      DIMENSION FUEL(9,4,10,2)
      INTEGER IP,ID,IR,JR,YR,IT,IF,IFJ,I,J,K,L,M,N
      REAL FUEL,GENDUM
      REAL GENDIFF(4,4,4) ! gendiff(prime mover, fuel, region)
      REAL TOTDIFF(3)
      REAL CONDIFF(4,4,4) ! condiff(prime mover, fuel, region)
      REAL GENSUM(4,6,4) ! gensum(prime mover,fuel,region)
      REAL GENBYP(4,4)
      REAL BIOSUM
      REAL STGEN(4,6) ! implied elec generation in steam turbine by fuel
      real prime ! division, year, inddir, prime mover
      real fueladd(4,6) ! cogeneration fuel to add to bsc fuel, region & fuel
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW
C******

      INTEGER IUNIT20

C****
C  DECLARE DATA STATEMENTS; HEAT RATES FOR EI-867 GENERATION
C  USE AVERAGE OF COAL AND GAS FOR OIL FOR YEARS AFTER 1992
C  SINCE IT SEEMS WAY TO HIGH BY ITSELF
C  GROWTH RATE OF OTHER INDUSTRIAL COGEN TO BE APPLIED AFTER
C  1998 AND BEYOND
C****

C****
C  WRITE SUBROUTINE TRACE.
C****

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C***
C  COMPUTE FUELS CONSUMPTION FOR OTHER INDUSTRIAL COGENERATION
C*****
       IF(INDNUM.EQ.1.AND.INDREG.EQ.1) THEN
         DO I = 1,9 ! division
          DO J = 1,6 ! fuel
           DO K = 1,3 ! prime mover
              OTHFUEL(I,J,K) = 0.0
           ENDDO
          ENDDO
         ENDDO
       ENDIF
       IF(INDREG.EQ.1) THEN
         DO I = 1,4 ! region   
          DO J = 1,6 ! fuel
              FUELadd(I,J) = 0.0
           ENDDO
          ENDDO
       ENDIF


        YR = IYR - 1989
        JR = YR
        IF(YR.GT.MAXCOGYR) JR = 6
C*****
C  First, calculate total output by division
C*****
       IF(INDREG.EQ.1) THEN
          L = 1
          M = 2
       ELSE IF(INDREG.EQ.2) THEN
          L = 3
          M = 4
       ELSE IF(INDREG.EQ.3) THEN
          L = 5
          M = 7
       ELSE IF(INDREG.EQ.4) THEN
          L = 8
          M = 9
       ENDIF
C*****
C   Calculate gridshare by region
C*****
           DO I = L,M  ! division to region
            DO J= 1,6 ! nems fuels
             DO K = 1,3 ! prime movers
              FUEL(I,K,J,1) = 0.0
              FUEL(I,K,J,2) = 0.0
              SICGEN(I,YR,INDDIR,J,K,1) = 0.0
              SICGEN(I,YR,INDDIR,J,K,2) = 0.0
              ENDDO
             ENDDO
            ENDDO

              DO I = L,M ! division to region
               DO IP = 1,3 ! prime movers
                 DO IF = 1,6 ! internal fuels

                SICGEN(I,YR,INDDIR,IF,IP,1)=
     1           SICGEN(I,YR,INDDIR,IF,IP,3)*
     1              IGRIDSHR(I,JR,INDDIR)

                SICGEN(I,YR,INDDIR,IF,IP,2)=
     1              SICGEN(I,YR,INDDIR,IF,IP,3)*
     1            (1-IGRIDSHR(I,JR,INDDIR))

                 ENDDO
               ENDDO
              ENDDO

             DO I = L,M ! division
              DO IP = 1,3 ! prime mover
               DO IF = 1,6  ! fuel
                FUEL(I,IP,IF,1)=
     1           SICGEN(I,YR,INDDIR,IF,IP,1)*RATE(IP)/10**6


                FUEL(I,IP,IF,2)=
     1            SICGEN(I,YR,INDDIR,IF,IP,2)*RATE(IP)/10**6


               ENDDO
              ENDDO
             ENDDO
c *** this code is now obsolete, should i delete it?
C***
C   Take difference between EI-867 and Industrial generation
C***
            DO I = L,M ! division
             DO IP = 1,3 ! prime mover
                DO IF = 1,6 ! fuel
                  GENSUM(IP,IF,INDREG) = 0.0 
                ENDDO
               ENDDO
              ENDDO 

            DO I = L,M  ! division aggregated to region
             DO IP = 1,3 ! prime mover
                DO IF = 1,6 ! fuel
                  GENSUM(IP,IF,INDREG) = GENSUM(IP,IF,INDREG) + 
     1             SICGEN(I,YR,INDDIR,IF,IP,3)*3412.0/10**6 ! trbtu
                ENDDO
               ENDDO
              ENDDO 

              
                 DO I = L,M ! division
                   DO J = 1,6 ! fuel
                    OTHFUEL(I,J,1) = OTHFUEL(I,J,1)+
     1               FUEL(I,1,J,1) + FUEL(I,2,J,1) +
     1               FUEL(I,3,J,1) + FUEL(I,4,J,1)


                    OTHFUEL(I,J,2) = OTHFUEL(I,J,2)+
     1               FUEL(I,1,J,2) + FUEL(I,2,J,2) +
     1               FUEL(I,3,J,2) + FUEL(I,4,J,2)
                    ENDDO
                  ENDDO

C****
C  CALCULATE FUEL CONSUMPTION FOR ELECTRICITY GENERATION FROM
C  NON-STEAM TURBINES.
C****

C****
C    FROM INTERNAL COMBUSTION ENGINE. (ASSUME ALL DIESEL)
C****

      ICEFUEL=ELGEN(1)*GENEQPHTRT(1)/3412.0 ! Trillion Btu

C****
C    FROM COMBUSTION TURBINE. (ASSUME ALL NATURAL GAS)
C****

      GCTFUEL=ELGEN(2)*GENEQPHTRT(2)/3412.0 ! Trillion Btu

C ***** LBNL ***** REMOVING INCREMENTAL GAS COGENERATION FROM GCTFUEL CALC
      IF ((IYR.GE.2001) .AND. (IYR.LT.2010)) THEN
         GCTFUEL=GCTFUEL / (6.0 * (IYR - 1999.0) / 10 )
         GCTFUEL=GCTFUEL +
     *         ELGEN(2) * 5.0/6.0 * (IYR - 1999.0) / 10 * 1.75
      ELSE IF (IYR.GE.2010) THEN
         GCTFUEL=GCTFUEL / 6.0
         GCTFUEL=GCTFUEL +
     *         ELGEN(2) * 5.0/6.0 * 1.75    ! 1.75 HEAT RATE FOR INCREMENTAL GAS COGEN
      ENDIF
C ***** LBNL END *****

C****
C  CALCULATE FUEL CONSUMPTION FOR STEAM TURBINES AND
C  PROCESS BOILERS.
C****

      CALL FUELBOIL
C***
C   CALCULATE IMPLIED GENERATION BY FUEL IN THE STEAM TURBINE
C***

      DO I = 1,3
        STGEN(I,INDREG) = 0.0
      ENDDO

      DO I = 1,3 ! implied purchased fuel generation
        STGEN(I,INDREG) = STFUEL(I)*3412.0/GENEQPHTRT(3)
      ENDDO

      DO I = 1,IFSBYP ! implied biomass generation
        GENBYP(I,INDREG) = STBYP(I)*3412.0/GENEQPHTRT(3)
      ENDDO
C****
C     Take difference between EI-867 and Industrial Generation
C     and apply heatrate to get consumption
C****
C COAL: All coal is consumed in steam turbines
c       GENDIFF(3,1,INDREG) = GENSUM(3,1,INDREG)
c    1     - STGEN(1,INDREG)

c       CONDIFF(3,1,INDREG) = GENDIFF(3,1,INDREG)*RATE(3)/3412.0



C DIESEL : Diesel consumed in combustion engine and steam turbine
c     GENDIFF(1,2,INDREG) = GENSUM(1,2,INDREG)- ELGEN(1)  

c     CONDIFF(1,2,INDREG) = GENDIFF(1,2,INDREG)*RATE(1)/3412.0  

 
c     GENDIFF(3,2,INDREG) = GENSUM(3,2,INDREG) - 
c    1                          STGEN(2,INDREG)

c     CONDIFF(3,2,INDREG) = GENDIFF(3,2,INDREG)*RATE(3)/3412.0

C GAS    :  Gas consumed in gas turbine and steam turbine

c     GENDIFF(2,3,INDREG) = GENSUM(2,3,INDREG)-ELGEN(2) 

c     CONDIFF(2,3,INDREG) = GENDIFF(2,3,INDREG)*RATE(2)/3412.0 

c     GENDIFF(3,3,INDREG) =  GENSUM(3,3,INDREG) -  STGEN(3,INDREG)

c     CONDIFF(3,3,INDREG) =  GENDIFF(3,3,INDREG)*RATE(3)/3412.0

C BIOMASS : All biomass is consumed in the steam turbine

c     BIOSUM = 0.0 
c     DO I = 1,IFSBYP
c       BIOSUM = BIOSUM + GENBYP(I,INDREG)
c     ENDDO

c     GENDIFF(3,4,INDREG) = GENSUM(3,4,INDREG) - BIOSUM
c     CONDIFF(3,4,INDREG) = GENDIFF(3,4,INDREG)*RATE(3)/3412.0

 
c     DO I = 1,3
c       DO J = 1,4
c        IF(GENDIFF(I,J,INDREG).LE.0.0) THEN
c          GENDIFF(I,J,INDREG) = 0.0
c          CONDIFF(I,J,INDREG) = 0.0
c        ENDIF
c      ENDDO
c     ENDDO

c     DO I = 1,IFSBYP ! add incremental difference to biomass cogen
c       STBYP(I) = STBYP(I) + CONDIFF(3,4,INDREG)/IFSBYP
c       bypbscr(i) = bypbscr(i) + condiff(3,4,indreg)/ifsbyp
c     ENDDO
C***
C    ADD EI-867 AND INDUSTRIAL FUEL INPUT DELTA TO TOTAL
C    BOILER FUEL 
C***
c skipping this for now
c     DO IF = 1,IFSMAX
c       IF(IFSLOC(IF).EQ.7) THEN
c         ENSQTY(IF) = ENSQTY(IF) + CONDIFF(3,1,INDREG) 
c       ENDIF
c       IF(IFSLOC(IF).EQ.11) THEN
c         ENSQTY(IF) = ENSQTY(IF) + CONDIFF(1,2,INDREG) +
c    1                              CONDIFF(3,2,INDREG)
c       ENDIF
c       IF(IFSLOC(IF).EQ.4) THEN
c         ENSQTY(IF) = ENSQTY(IF) + CONDIFF(2,3,INDREG) +
c    1                              CONDIFF(3,3,INDREG)
c       ENDIF
c     ENDDO 

c this is the alternative for now, add all of cogen consumption to total
c adding half of the cogen electric in tbtu equivalents is roughly equivalent
c to a 6800 heat rate

            DO I = L,M  ! division aggregated to region
             DO IP = 1,3 ! prime mover
                DO IF = 1,6 ! fuel
                  fueladd(INDREG,if) = fueladd(indreg,if) + 0.5 *
     1            (SICGEN(I,YR,INDDIR,IF,IP,3)*3412.0/10**6)! trbtu
C ***** LBNL --- ACCOUNTING FOR GAS COGEN WITH HEATRATE OF 1.75 *****
                  IF ((IYR.GE.2001) .AND. (IYR.LT.2010)) THEN
                     fueladd(INDREG,if) = fueladd(INDREG,if) -
     *                    0.5 * 5.0/6.0 * (IYR - 1999.0) / 10 *     
     *                    (SICGEN(I,YR,INDDIR,IF,IP,3)*3412.0/10**6)
                  ELSE IF (IYR.GE.2010) THEN
                     fueladd(INDREG,if) = fueladd(INDREG,if) -
     *                    0.5 * 5.0/6.0 * 
     *                    (SICGEN(I,YR,INDDIR,IF,IP,3)*3412.0/10**6)
                  ENDIF
C ***** LBNL END *****

                ENDDO
               ENDDO
              ENDDO 
      do i=l,m
      DO IF = 1,IFSMAX
        IF(IFSLOC(IF).EQ.7) THEN ! steam coal
          ENSQTY(IF) = ENSQTY(IF) + fueladd(indreg,1)
        ENDIF
        IF(IFSLOC(IF).EQ.10) THEN ! residual
          ENSQTY(IF) = ENSQTY(IF) + fueladd(indreg,2)
        ENDIF
        IF(IFSLOC(IF).EQ.4) THEN ! natural gas
          ENSQTY(IF) = ENSQTY(IF) + fueladd(indreg,3)
        ENDIF
        if(ifsloc(if).eq.42) then ! biomass,wood
        bypbscr(if) = bypbscr(if) + fueladd(indreg,5) ! biomass,wood
        endif
      ENDDO
      enddo


C****
C  Sum generation and capacity by region to get a national 
C  total
C****
C*** obsolete *
C   add the total generation differential between industrial and the ei-867
C****
c     DO J = 1,3
c      TOTDIFF(J) = 0.0
c     ENDDO

c      DO I = 1,3 ! prime mover
c       DO J = 1,4 ! fuel
c        TOTDIFF(I) = TOTDIFF(I) + GENDIFF(I,J,INDREG)
c       ENDDO
c      ENDDO

          ELOWN(7) = 0.0
          ELSALE(7) = 0.0
        DO J = 1,3
c         ELOWN(J)= ELOWN(J)+TOTDIFF(J)*
c    1                     (1-GRDSHRG(INDREG,INDDIR))

c         ELSALE(J) =  ELSALE(J) +  TOTDIFF(J)*
c    1                           GRDSHRG(INDREG,INDDIR)
        

          ELOWN(7) = ELOWN(7) + ELOWN(J)
          ELSALE(7) = ELSALE(7) + ELSALE(J)


        ENDDO
          

C****
C  CALCULATE THE FUELS CONSUMED FOR COGENERATION.
C  1 = COAL
C  2 = OIL
C  3 = NATURAL GAS
C  4 = RENEWABLES/OTHER
C****

C****
C    INITIALIZE GENFUEL.
C****
        IF(INDREG.EQ.1) THEN
         DO IR=1,5
          DO IT=1,3
            DO IF=1,5
               GENFUEL(IF,IT,IR)=0.0
               CGFUEL(IF,IT,IR)=0.0
            ENDDO
          ENDDO
         ENDDO
        ENDIF
C****
C    FROM INTERNAL COMBUSTION ENGINES (ALL DIESEL)
C****

      CGFUEL(2,3,INDREG)=ICEFUEL + CONDIFF(1,2,INDREG)+
     1                             CONDIFF(3,2,INDREG)
C****
C    FROM COMBUSTION TURBINES (ALL GAS)
C****

      CGFUEL(3,3,INDREG)=GCTFUEL + CONDIFF(2,3,INDREG)+
     1                             CONDIFF(3,3,INDREG)
C****
C    FROM STEAM TURBINES
C****
      DO 160 IF=1,IFSMAX

C  COAL
        IF(IFSLOC(IF).EQ.7)CGFUEL(1,3,INDREG)=
     1                       CGFUEL(1,3,INDREG)+STFUEL(IF)+
     1                       CONDIFF(3,1,INDREG)

C  OIL
        IF(IFSLOC(IF).EQ.10.OR.
     1     IFSLOC(IF).EQ.11.OR.
     1     IFSLOC(IF).EQ.12.OR.
     1     IFSLOC(IF).EQ.14.OR.
     1     IFSLOC(IF).EQ.15.OR.
     1     IFSLOC(IF).EQ.16.OR.
     1     IFSLOC(IF).EQ.20.OR.
     1     IFSLOC(IF).EQ.22)
     1     CGFUEL(2,3,INDREG)=CGFUEL(2,3,INDREG)+STFUEL(IF)+
     1                                       CONDIFF(3,2,INDREG)

C  NATURAL GAS
        IF(IFSLOC(IF).EQ.4) CGFUEL(3,3,INDREG)=
     1                        CGFUEL(3,3,INDREG)+STFUEL(IF)+
     1                                       CONDIFF(3,3,INDREG)

C  RENEWABLES/OTHER
        IF(IFSLOC(IF).EQ.42.OR.IFSLOC(IF).EQ.43)
     1      CGFUEL(4,3,INDREG)=CGFUEL(4,3,INDREG)+STFUEL(IF)


  160 CONTINUE

      DO IF=1,IFSBYP
        IF(IFSLOCBY(IF).EQ.42.OR.IFSLOCBY(IF).EQ.43)
     1   CGFUEL(4,3,INDREG)=CGFUEL(4,3,INDREG)+STBYP(IF)+
     1           CONDIFF(3,4,INDREG)/IFSBYP
      ENDDO

C****
C  SHARE THE FUEL CONSUMED BETWEEN OWN AND SALES.
C****

      DO 170 IF=1,3
c      IF(ELGEN(5).GT.0.0) THEN
         CGFUEL(IF,2,INDREG)=CGFUEL(IF,3,INDREG)*
     1                             (1-GRDSHRG(INDREG,INDDIR))
         CGFUEL(IF,1,INDREG)=CGFUEL(IF,3,INDREG)-
     1                             CGFUEL(IF,2,INDREG)
          IF(CGFUEL(IF,1,INDREG).LT.0.0)CGFUEL(IF,1,INDREG)=0.0
         CGFUEL(4,2,INDREG)=CGFUEL(4,3,INDREG)*
     1                             (1-GRDSHRG(INDREG,INDDIR))
         CGFUEL(4,1,INDREG)=CGFUEL(4,3,INDREG)-
     1                             CGFUEL(4,2,INDREG)
          IF(CGFUEL(4,1,INDREG).LT.0.0)CGFUEL(4,1,INDREG)=0.0
c      ENDIF
  170 CONTINUE


c      IF(GEN90.EQ.0.0)THEN
c          DO IF=1,5
c            DO IT=1,3
c               CGFUEL(IF,IT,INDREG)=0.0
c            ENDDO
c          ENDDO
c      ENDIF
C****
C  SUM UP OVER FUEL CATEGORIES.
C****

      DO 180 IT=1,3
         DO 180 IF=1,4
            CGFUEL(5,IT,INDREG)=CGFUEL(5,IT,INDREG)+
     1        CGFUEL(IF,IT,INDREG) 
  180 CONTINUE

      IF(INDREG.EQ.4) THEN
        DO 185 IF=1,5
          DO 185 IT=1,3
            DO 185 IR=1,4
              CGFUEL(IF,IT,5)=CGFUEL(IF,IT,5)+CGFUEL(IF,IT,IR)
              GENFUEL(IF,IT,5)=CGFUEL(IF,IT,5)
  185 CONTINUE
      ENDIF

       DO IF=1,5
        DO IT=1,3
          GENFUEL(IF,IT,INDREG)=CGFUEL(IF,IT,INDREG)
        ENDDO
       ENDDO

      DO 193 IF=1,5
        DO 193 IT=1,2
            IF(INDNUM.EQ.1)  GENTOT(IF,IT,INDREG)=0.0
  193    CONTINUE

      DO 195 IF=1,5
        DO 195 IT=1,2
           GENTOT(IF,IT,INDREG)=GENTOT(IF,IT,INDREG)+
     1                          CGFUEL(IF,IT,INDREG)
  195  CONTINUE


C****
C  WRITE VARIOUS INFORMATION TO DEBUG FILE, IF ON.
C****

      IF(IWDBG.EQ.1) THEN

C****
C    WRITE STEAM INTENSITY, SHARES, CONSUMPTION.
C****

        IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)WRITE(IUNIT1,799)
C        DO 200 IV=1,4
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,801) (ENSINT(IF),IF=1,IFSMAX)
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,8011)(BYSINT(IF),IF=1,IFSBYP)
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,803) (BSSHR(IF),IF=1,IFSMAX)
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,805) (ENSQTY(IF),IF=1,IFSMAX)
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,823) (STFUEL(IF),IF=1,IFSMAX)
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,824) ICEFUEL,GCTFUEL
  200   CONTINUE

C****
C    WRITE FUELS CONSUMED FOR ELECTRICITY GENERATION.
C****

        IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)WRITE(IUNIT1,821)
        DO 210 IT=1,3
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,822) IT,(GENFUEL(IF,IT,5),IF=1,5)
  210   CONTINUE
      ENDIF

C****
C FORMAT STATEMENTS.
C****

  799 FORMAT(1X,'BSC INTENSITY, SHARES & CONSUMPTION BY FUEL:')
  800 FORMAT(4X,'VINTAGE=',I1)
  801 FORMAT(2X,'FUEL INTENSITY: ',8F8.3)
  803 FORMAT(2X,'SHARES:    ',8F8.3)
  805 FORMAT(2X,'FUELS CONSUMP:   ',8F8.1)
  806 FORMAT(2X,'BYPRODUCT CONSUMP:   ',8F8.1)
  821 FORMAT(1X,'FUELS CONSUMED TO GENERATE ELECTRICITY:')
  822 FORMAT(2X,'GENER TYPE ',I1,':',5F8.1)
  823 FORMAT(2X,'STFUEL ',I1,':',5F8.1)
  824 FORMAT(2X,'ICFUEL,GCTFUEL ',I1,':',2F8.1)
  991 FORMAT(3X,'CALSTOT')
 8011 FORMAT(2X,'BYPRODUCT INTENSITY: ',8F8.3)

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  THIS SUBROUTINE CALCULATES TOTAL FUEL CONSUMPTION FOR
C  STEAM TURBINES AND PROCESS BOILERS.
C****
      SUBROUTINE FUELBOIL
      IMPLICIT NONE
      INCLUDE(INDALL)

      DIMENSION BYSQTY(10),FUELSHR(10),BYPSHR(10)
      REAL AVGINT,TDEM,STEMP(10)
      INTEGER IF,IT,IR,IFX,IFY,IFJ,YR,I,J,K,JR
      REAL BYSQTY,TEMP,STEMCURF,FUELTOT,FUELSHR,BYPSHR

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  CALCULATE AVERAGE INTENSITY (HEAT RATE) FOR EACH VINTAGE.
C****

        AVGINT=0.0
        DO 110 IF=1,IFSMAX
          AVGINT=AVGINT+BSSHR(IF)*ENSINT(IF)
  110 CONTINUE

C****
C  CALCULATE THE AMOUNT OF STEAM GENERATED BY THE BYPRODUCT FUELS.
C****

        BYPSTMM=0.0
        BYPSTMI=0.0
        BYPSTMR=0.0
        DO 112 IF=1,IFSBYP
          IFX=IFSLOCBY(IF)
          IF(IFX.LE.30) THEN
            BYSQTY(IF)=BYPBSCM(IFX)
            IF(BYSINT(IF).EQ.0.0) THEN
              TEMP=0.0
            ELSE
              TEMP=1/BYSINT(IF)
            ENDIF
            BYPSTMM=BYPSTMM+(BYSQTY(IF)*TEMP)
          ELSE
            IF(IFX.LE.40) THEN
              IFY=IFX-30
              BYSQTY(IF)=BYPBSCI(IFY)
              IF(BYSINT(IF).EQ.0.0) THEN
                TEMP=0.0
              ELSE
                TEMP=1/BYSINT(IF)
              ENDIF
              BYPSTMI=BYPSTMI+(BYSQTY(IF)*TEMP)
            ELSE
              IFY=IFX-40
              BYSQTY(IF)=BYPBSCR(IFY)
              IF(BYSINT(IF).EQ.0.0) THEN
                TEMP=0.0
              ELSE
                TEMP=1/BYSINT(IF)
              ENDIF
              BYPSTMR=BYPSTMR+(BYSQTY(IF)*TEMP)
            ENDIF
          ENDIF
  112 CONTINUE
      BYPSTM=BYPSTMM+BYPSTMI+BYPSTMR

C****
C  DETERMINE AMOUNT OF STEAM TO BE GENERATED BY PURCHASED FUELS.
C****

        STEMCURF= STEMCUR - BYPSTM
        IF(STEMCURF.LT.0.0)STEMCURF=0.0

C****
C  FROM THE TOTAL STEAM DEMAND AND THE AVERAGE INTENSITY (heatrate)
C  THE TOTAL AMOUNT OF FUEL CONSUMED TO GENERATE STEAM IS DETERMINED.
C  THEN THE TOTAL IS SHARED TO EACH FUEL TYPE BASED ON THEIR SHARES.
C****

        TDEM=STEMCURF*AVGINT
        DO 120 IF=1,IFSMAX
          ENSQTY(IF)=TDEM*BSSHR(IF)
  120 CONTINUE
C****
C  THE ICEFUEL AND GCTFUEL MUST BE SUBTRACTED OUT OF THE
C  TOTAL BSC CONSUMPTION BEFORE CALCULATING THE OWN/SALES
C****

       DO IF=1,IFSMAX
C         INTERNAL COMBUSTION ENGINE (DIESEL)
          IF(IFSLOC(IF).EQ.11)THEN
              ENSQTY(IF)=ENSQTY(IF) -  ICEFUEL
              IF(ENSQTY(IF).LT.0.0) ENSQTY(IF)=0.0
          ENDIF
C         COMBUSTION TURBINE (NATURAL GAS)
            IF(IFSLOC(IF).EQ.4)THEN
              ENSQTY(IF)=ENSQTY(IF) - GCTFUEL
              IF(ENSQTY(IF).LT.0.0) ENSQTY(IF)=0.0
            ENDIF
        ENDDO

C****
C  CALCULATE BOILER FUEL SHARES THAT INCLUDES THE BYPRODUCT FUELS.
C****


      FUELTOT=0.0
      DO IF=1,IFSMAX
        FUELTOT=FUELTOT+ENSQTY(IF)
      ENDDO
      DO IF=1,IFSBYP
        FUELTOT=FUELTOT+BYSQTY(IF)
      ENDDO
      IF(FUELTOT.NE.0.0) THEN
        DO IF=1,IFSMAX
          FUELSHR(IF)=ENSQTY(IF)/FUELTOT
        ENDDO
        DO IF=1,IFSBYP
          BYPSHR(IF)=BYSQTY(IF)/FUELTOT
        ENDDO
      ENDIF
C****
C  DETERMINE THE AMOUNT OF FUELS CONSUMED IN STEAM TURBINES.
C  ALSO DETERMINE OUTPUT BY TYPE OF FUEL IN STEAM TURBINE
C  AND SUBTRACT FROM EI-867
C****


C  INITIALIZE ARRAY STEMP


        DO IF=1,IFSMAX
          STFUEL(IF)=(FUELSHR(IF)*ELGEN(3))*GENEQPHTRT(3)/3412.0
        ENDDO

        DO IF=1,IFSBYP
          STBYP(IF)=(BYPSHR(IF)*ELGEN(3))*GENEQPHTRT(3)/3412.0
        ENDDO


       DO IF=1,IFSMAX
C          INTERNAL COMBUSTION ENGINE (DIESEL)
           IF(IFSLOC(IF).EQ.11)THEN
               ENSQTY(IF)=ENSQTY(IF) + ICEFUEL
          ENDIF

C          COMBUSTION TURBINE (NATURAL GAS)
             IF(IFSLOC(IF).EQ.4)THEN
               ENSQTY(IF)=ENSQTY(IF) +  GCTFUEL
             ENDIF
       ENDDO



C****
C FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'FUELBOIL')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CONSUMPTION FOR THE INDUSTRY COMPONENTS ARE CONSOLIDATED INTO
C  ONE TOTAL, AND INDUSTRIES ARE ADDED INTO AN OVERALL INDUSTRIAL
C  TOTAL. ALSO CALCULATE TOTALS FOR METAL BASED DURABLES AND
C  OTHER MANUFACTURING
C****
      SUBROUTINE INDTOTAL
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IF,IFF,IR,IY
      INTEGER I,J
      REAL ELECTEMP
      REAL SUM

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)


C****
C  INITIALIZE THE QTY ARRAYS.
C****
           

          DO IF=1,23
            QTYMAIN(IF,INDREG)=0.0
          ENDDO
          DO IF=1,7
            QTYINTR(IF,INDREG)=0.0
          ENDDO
          DO IF=1,9
            QTYRENW(IF,INDREG)=0.0
          ENDDO
          if (indnum.eq.1) then
          do if=1,3
             xelin(if,indreg)=0.0
             xelinshr(if,indreg)=0.0
          enddo
          endif

           

C****
C  THE PA QUANTITIES ARE PUT IN THE TOTAL ARRAYS.
C****

      DO IF=1,22
        QTYMAIN(IF,INDREG)=ENPMQTY(IF)
      ENDDO
      DO IF=1,6
        QTYINTR(IF,INDREG)=ENPIQTY(IF)
      ENDDO
      DO IF=1,8
        QTYRENW(IF,INDREG)=ENPRQTY(IF)
      ENDDO

C****
C  ADD PURCHASED ELECTRICITY FROM BLD
C****
       
      QTYMAIN(1,INDREG)=QTYMAIN(1,INDREG)+ENBQTY(3,1)

C****
C  ADD CORE NATURAL GAS FROM BLD
C****
      QTYMAIN(3,INDREG)=QTYMAIN(3,INDREG)+ENBQTY(3,2)

C****
C  ADD STEAM FROM BLD
C****

      QTYINTR(1,INDREG)=QTYINTR(1,INDREG)+ENBQTY(3,3)

C****
C  BSC ENERGY SOURCES HAVE TO BE TRANSLATED.
C****

      DO 80 IF=1,IFSMAX
        IF(IFSLOC(IF).LT.30) THEN
          IFF=IFSLOC(IF)
          QTYMAIN(IFF,INDREG)=QTYMAIN(IFF,INDREG)+ENSQTY(IF)
        ELSE
          IF(IFSLOC(IF).LT.40) THEN
            IFF=IFSLOC(IF)-30
            QTYINTR(IFF,INDREG)=QTYINTR(IFF,INDREG)+ENSQTY(IF)
          ELSE
            IFF=IFSLOC(IF)-40
            QTYRENW(IFF,INDREG)=QTYRENW(IFF,INDREG)+ENSQTY(IF)
          ENDIF
        ENDIF
   80 CONTINUE

C****
C  ADD BYPRODUCT FUEL USED.
C****

      DO IF=1,22
        QTYMAIN(IF,INDREG)=QTYMAIN(IF,INDREG)+BYPBSCM(IF)
      ENDDO
      DO IF=1,6
        QTYINTR(IF,INDREG)=QTYINTR(IF,INDREG)+BYPBSCI(IF)
      ENDDO
      DO IF=1,8
        QTYRENW(IF,INDREG)=QTYRENW(IF,INDREG)+BYPBSCR(IF)
      ENDDO

C****
C  QTYMAIN(1,IR) IS DEFINED AS PURCHASED ELECTRICITY ONLY.
C****
C GET TOTAL OWN USE GENERATION
c elown is in trillion btu
     
      ELECTEMP=QTYMAIN(1,INDREG)-ELOWN(7)
      IF(ELECTEMP.GE.0.0) THEN
        QTYMAIN(1,INDREG)=ELECTEMP
      ELSE
        QTYMAIN(1,INDREG)=0.0
      ENDIF

C****
C  DO TOTALS.
C****

      DO IF=1,22
        QTYMAIN(23,INDREG)=QTYMAIN(23,INDREG)+QTYMAIN(IF,INDREG)
      ENDDO
      DO IF=1,6
        QTYINTR(7,INDREG)=QTYINTR(7,INDREG)+QTYINTR(IF,INDREG)
      ENDDO
      DO IF=1,8
        QTYRENW(9,INDREG)=QTYRENW(9,INDREG)+QTYRENW(IF,INDREG)
      ENDDO

c  also calculate electricity shares for the three 
c  groups: Primary=food,paper,chemicals,steel,aluminum;
c          Shift  =metal based durables;
c          Miscellaneous =all the rest.
      if (inddir.eq.7.or.inddir.eq.8.or.inddir.eq.9.or.
     1    inddir.eq.12.or.inddir.eq.13) then
          xelin(1,indreg)=xelin(1,indreg) +
     1                     qtymain(1,indreg)
        else if (inddir.eq.14) then
          xelin(2,indreg)=xelin(2,indreg) +
     1                     qtymain(1,indreg)
        else
          xelin(3,indreg)=xelin(3,indreg) +
     1                     qtymain(1,indreg)
      endif
      xelinshr(1,indreg)=xelin(1,indreg)/
     1 (xelin(1,indreg)+
     1  xelin(2,indreg)+
     1  xelin(3,indreg))

       xelinshr(2,indreg)=xelin(2,indreg)/
     1 (xelin(1,indreg)+
     1  xelin(2,indreg)+
     1  xelin(3,indreg))

      xelinshr(3,indreg)=xelin(3,indreg)/
     1 (xelin(1,indreg)+
     1  xelin(2,indreg)+
     1  xelin(3,indreg))

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'INDTOTAL')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CONSUMPTION FOR THE INDUSTRY COMPONENTS ARE CONSOLIDATED INTO
C  ONE TOTAL, AND INDUSTRIES ARE ADDED INTO AN OVERALL INDUSTRIAL
C  TOTAL.
C****
      SUBROUTINE NATTOTAL
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IF,IFF,IR

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  INITIALIZE TO 0.0 THE NATIONAL VARIABLES.
C****

      DO IF=1,23
        QTYMAIN(IF,5)=0.0
      ENDDO

      DO IF=1,7
        QTYINTR(IF,5)=0.0
      ENDDO

      DO IF=1,9
        QTYRENW(IF,5)=0.0
      ENDDO

C****
C  CALCULATE NATIONAL TOTALS.
C****

      DO IF=1,22
        DO IR=1,4
          QTYMAIN(IF,5)=QTYMAIN(IF,5)+QTYMAIN(IF,IR)
        ENDDO
      ENDDO

      DO IF=1,6
        DO IR=1,4
          QTYINTR(IF,5)=QTYINTR(IF,5)+QTYINTR(IF,IR)
        ENDDO
      ENDDO

      DO IF=1,8
        DO IR=1,4
          QTYRENW(IF,5)=QTYRENW(IF,5)+QTYRENW(IF,IR)
        ENDDO
      ENDDO

C****
C  SUM UP TOTALS OVER FUELS.
C****

      DO 100 IR=1,5
        QTYMAIN(23,IR)=0.0
        DO 100 IF=1,22
          QTYMAIN(23,IR)=QTYMAIN(23,IR)+QTYMAIN(IF,IR)
  100 CONTINUE

      DO 102 IR=1,5
        QTYINTR(7,IR)=QTYINTR(1,IR)+QTYINTR(2,IR)+QTYINTR(3,IR)
     1        +QTYINTR(4,IR)+QTYINTR(5,IR)+QTYINTR(6,IR)
  102 CONTINUE

      DO 105 IR=1,5
        QTYRENW(9,IR)=0.0
        DO 105 IF=1,8
          QTYRENW(9,IR)=QTYRENW(9,IR)+QTYRENW(IF,IR)
  105 CONTINUE

C****
C  THE ARRAYS ARE ADDED UP OVER THE VARIOUS INDUSTRIES.
C****

      DO 150 IR=1,5
        DO IF=1,23
          IF(INDNUM.EQ.1) THEN
            TQMAIN(IF,IR)=0.0
          ENDIF
          TQMAIN(IF,IR)=TQMAIN(IF,IR)+QTYMAIN(IF,IR)
        ENDDO
        DO IF=1,7
          IF(INDNUM.EQ.1) THEN
            TQINTR(IF,IR)=0.0
          ENDIF
          TQINTR(IF,IR)=TQINTR(IF,IR)+QTYINTR(IF,IR)
        ENDDO
        DO IF=1,9
          IF(INDNUM.EQ.1) THEN
            TQRENW(IF,IR)=0.0
          ENDIF
          TQRENW(IF,IR)=TQRENW(IF,IR)+QTYRENW(IF,IR)
        ENDDO
  150 CONTINUE

C****
C  FORMAT STATEMENTS.
C****

  991 FORMAT(3X,'NATTOTAL')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  TOTAL ENERGY CONSUMPTION FOR THE INDUSTRY IS WRITTEN TO THE
C  DEBUG FILE.
C****
      SUBROUTINE WRQTY
      IMPLICIT NONE
      INCLUDE(INDALL)

      INTEGER IF,IR

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  WRITE OVERALL CONSUMPTION TO DEBUG FILE.
C****

      IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1 WRITE(IUNIT1,900) IYR,QTYMAIN(23,INDREG),
     1                   QTYINTR(7,INDREG),QTYRENW(9,INDREG)

      IF(INDREG.EQ.4) THEN
        IF(IWDBG.EQ.1) THEN
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)WRITE(IUNIT1,875)
          DO IF=1,23
            IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1           WRITE(IUNIT1,877) IF,(QTYMAIN(IF,IR),IR=1,5)
          ENDDO
          DO IF=1,7
            IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1           WRITE(IUNIT1,877) IF,(QTYINTR(IF,IR),IR=1,5)
          ENDDO
          DO IF=1,9
            IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1           WRITE(IUNIT1,877) IF,(QTYRENW(IF,IR),IR=1,5)
          ENDDO
        ENDIF
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  875 FORMAT(1X,'OVERALL CONSUMPTION BY FUEL')
  877 FORMAT(5X,'FUEL ',I4,5F10.1)
  900 FORMAT(' RESULTS FOR ',I4,':  MAIN=',F8.1,'  INTR=',F8.1,
     1  '  RENW=',F8.1)
  991 FORMAT(3X,'WRQTY')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  SUMMARY CONSUMPTION TABLE.  ONLY GOOD AS LONG AS THE MODEL STAYS
C  IN MEMORY OVER THE FULL FORECAST HORIZON.
C****
      SUBROUTINE SUMTAB
      IMPLICIT NONE
      INCLUDE(INDALL)

      DIMENSION QSUM(11,3,50)
      REAL QSUM,GTEMP
      CHARACTER*4 QNAME(11)
      INTEGER IY,IF

      DATA QNAME/'ELEC','NGAS','COAL','COKE','RESD','DIST','LGAS',
     1 'OPET','BIOM','TOTL','STEM'/

      IF(ISUBTR.EQ.1.AND.IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1  WRITE(IUNIT1,991)

C****
C  WRITE CONSUMPTION TO DEBUG FILE.
C****

      IY=(IYR-1980)/10
      QSUM(1,IY,INDNUM)=QTYMAIN(1,5)
      QSUM(2,IY,INDNUM)=QTYMAIN(3,5)+QTYMAIN(4,5)+QTYMAIN(5,5)+
     1                    QTYMAIN(6,5)
      QSUM(3,IY,INDNUM)=QTYMAIN(7,5)
      QSUM(4,IY,INDNUM)=QTYMAIN(8,5)+QTYMAIN(9,5)
      QSUM(5,IY,INDNUM)=QTYMAIN(10,5)
      QSUM(6,IY,INDNUM)=QTYMAIN(11,5)
      QSUM(7,IY,INDNUM)=QTYMAIN(12,5)+QTYMAIN(13,5)
      QSUM(8,IY,INDNUM)=QTYMAIN(14,5)+QTYMAIN(15,5)+QTYMAIN(16,5)+
     1                    QTYMAIN(17,5)+QTYMAIN(18,5)+
     1                    QTYMAIN(19,5)+QTYMAIN(20,5)+
     2                    QTYMAIN(21,5)+QTYMAIN(22,5)
      QSUM(9,IY,INDNUM)=QTYRENW(2,5)+QTYRENW(3,5)
      QSUM(10,IY,INDNUM)=QSUM(1,IY,INDNUM)+QSUM(2,IY,INDNUM)+
     1                     QSUM(3,IY,INDNUM)+QSUM(4,IY,INDNUM)+
     1                     QSUM(5,IY,INDNUM)+QSUM(6,IY,INDNUM)+
     2                     QSUM(7,IY,INDNUM)+QSUM(8,IY,INDNUM)+
     3                     QSUM(9,IY,INDNUM)
      QSUM(11,IY,INDNUM)=QTYINTR(1,5)

      IF(IYR.EQ.2010) THEN
        IF (IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1    WRITE(IUNIT1,950)INDNUM,INDDIR
        DO 50 IF=1,11
          IF(QSUM(IF,1,INDNUM).NE.0.0) THEN
            GTEMP=QSUM(IF,3,INDNUM)/QSUM(IF,1,INDNUM)
          ELSE
            GTEMP=0.0
          ENDIF
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1      WRITE(IUNIT1,951)
     1        QNAME(IF),(QSUM(IF,IY,INDNUM),IY=1,3),GTEMP
   50   CONTINUE

        DO IF=1,11
          DO IY=1,3
            QSUM(IF,IY,50)=QSUM(IF,IY,50)+QSUM(IF,IY,INDNUM)
          ENDDO
        ENDDO

        IF(INDNUM.EQ.INDMAX) THEN
          IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)WRITE(IUNIT1,960)
          DO 80 IF=1,11
            IF(QSUM(IF,1,50).NE.0.0) THEN
              GTEMP=QSUM(IF,3,50)/QSUM(IF,1,50)
            ELSE
              GTEMP=0.0
            ENDIF
            IF(IOPEN.EQ.1.AND.LSTITER.EQ.1)
     1        WRITE(IUNIT1,951)
     1        QNAME(IF),(QSUM(IF,IY,50),IY=1,3),GTEMP
   80     CONTINUE
        ENDIF
      ENDIF

C****
C  FORMAT STATEMENTS.
C****

  950 FORMAT(1X,'CONSUMPTION SUMMARY TABLE, INDUSTRY # ',2I5,/,19X,
     1 '1990      2000      2010    CHANGE')
  951 FORMAT(5X,A4,4X,3F10.1,F10.2)
  960 FORMAT(1X,'CONSUMPTION SUMMARY TABLE, INDUSTRY TOTAL',/,19X,
     1 '1990      2000      2010    CHANGE')
  991 FORMAT(3X,'SUMTAB')

      RETURN
      END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C THIS SUBROUTINE CALCULATES THE NECESSARY COGENERATION
C  VARIABLES TO BE PASSED TO THE NEMS SYSTEM.
C****
      SUBROUTINE INDCGN
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDALL)
      COMMON/COGSHR/CAPSHR(9,6,2),GRDSHRG(4,15),prime(11,32,15,4)

      REAL CAPSHR,GRDSHRG

      DIMENSION GROWCGN(10),HEATRATE(10)
      INTEGER ID,IF,IT,ICR,NUM(9),IR
      REAL OWNGEN(5,5),SALGEN(5,5),OWNSHR(5),SALSHR(5)
      REAL NGREGO(4),RSREGO(4),CLREGO(4),
     1 BMREGO(4),NGREGS(4),RSREGS(4),CLREGS(4),BMREGS(4),
     1 DIVSHARE(9),GEN(11,11,2),CAP(11,11,2)
       REAL TOTGEN,TOTCAP,TOTGRD,TOTOCAP,TOTSCAP,TOTSALE,TOTOWN
       REAL GROWCGN,TEMPX
       REAL CGTEMP,HEATRATE
       REAL SUMGEN(11,10,2)
       REAL SUMCAP(11,6,2)
       REAL FUELTOT(6,2)
       REAL FUELDIFF(9,6,2)
       REAL CAPDIFF(9,6,2)
       REAL GENFL(5,2)
       REAL INDCAP(11,6,2),INDGEN(11,6,2)
       REAL CTFUEL(4,5),ICFUEL(4,5),STBFUEL(4,5)
       real prime ! division, year, inddir, prime mover
       INTEGER IYEAR,IREGION,IFUEL
       INTEGER IY,I,J,K,L,SIC,YR,JR,IP

C****
C  DECLARE DATA STATEMENTS; HEAT RATES FOR EI-867 GENERATION
C  USE AVERAGE OF COAL AND GAS FOR OIL FOR YEARS AFTER 1992
C  SINCE IT SEEMS WAY TO HIGH BY ITSELF
C  GROWTH RATE OF OTHER INDUSTRIAL COGEN TO BE APPLIED AFTER
C  1998 AND BEYOND
C****
C  THE FUEL ORDER IS THE SAME AS THE COGEN ARRAY:
C  COAL, OIL, GAS, HYDRO, GEOTHERMAL, MSW, BIOMASS
C  SOLAR, WIND, OTHER.BIOMASS HEATRATE FROM AER
C****

c     DATA HEATRATE/6750,6500,6200,0.0,0.0,0.0,0.0,0.0,
c    1              0.0,0.0/


C fuelshares by REGION AND FUEL
C REGION1 REGION2 REGION3 REGION4
C      COAL OIL GAS WOOD OTHER

       DATA CTFUEL/0.0,0.005,0.995,0.0,0.0,
     1        0.0,0.0,0.997,0.003,0.0,
     1        0.0,0.0,1.0,0.0,0.0,
     1        0.0,0.0,1.0,0.0,0.0/

       DATA ICFUEL/0.0,0.53,0.47,0.0,0.0,
     1        0.0,0.0,1.0,0.0,0.0,
     1        0.0,0.07,0.93,0.0,0.0,
     1        0.0,0.38,0.57,0.05,0.0/

       DATA STBFUEL/0.43,0.11,0.23,0.23,0.0,
     1        0.67,0.005,0.14,0.18,0.005,
     1        0.24,0.01,0.23,0.48,0.04,
     1        0.30,0.0,0.18,0.49,0.03/
C****
C     ELECTRICITY SHARE FOR CENSUS DIVISION FROM SEDS 1990
C****

      DATA  DIVSHARE/.226,.774,.757,.243,.388,.276,
     1 .337,.319,.681/

C     NUMBER ASSIGNMENT FOR CENSUS DIVISION
      DATA  NUM/1,1,2,2,3,3,3,4,4/

C********
C     CALCULATE SHARE OF GENERATION ACROSS INDUSTRIES FOR DIVISION
C     I IN REGION K FOR FUEL J 
C********

      IY = IYR - 1989
C********
C
C   CALCULATE SHARES BY PRIME MOVER
C********
       IF(IYR.LE.1995) THEN
           JR = IY
       ELSE
           JR = 6
       ENDIF
C Compute total capacity by fuel for each division
          DO I = 1,11   ! divison
           DO J = 1,6  ! fuel
            SUMCAP(I,J,1) = 0.0
            SUMCAP(I,J,2) = 0.0
            CAPGW(I,J,1,1)=0.0
            CAPGW(I,J,2,1)=0.0
           ENDDO
          ENDDO

          DO I = 1,9 ! divisions
           DO K = 1,15 ! industry
                       

C CALCULATE CAPACITY FOR SALES TO GRID BY FUEL
             SUMCAP(I,1,1) = SUMCAP(I,1,1) + ! Coal
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,1)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,1)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,1)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,1))*
     1                          IGRIDSHR(I,JR,K)

            SUMCAP(I,2,1) = SUMCAP(I,2,1) +  ! Petroleum
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,2)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,2)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,2)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,2))*
     1                          IGRIDSHR(I,JR,K)


            SUMCAP(I,3,1) = SUMCAP(I,3,1) +  ! Natural Gas
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,3)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,3)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,3)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,3))*
     1          IGRIDSHR(I,JR,K)

            SUMCAP(I,4,1) = SUMCAP(I,4,1) +  !Wood
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,4)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,4)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,4)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,4))*
     1          IGRIDSHR(I,JR,K)

            SUMCAP(I,5,1) = SUMCAP(I,5,1) +  ! Other
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,5)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,5)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,5)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,5))*
     1       IGRIDSHR(I,JR,K)

            SUMCAP(I,6,1) = SUMCAP(I,6,1) +     ! MSW
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,6)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,6)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,6)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,6))*
     1       IGRIDSHR(I,JR,K)

C CALCULATE CAPACITY FOR OWN USE BY FUEL
             SUMCAP(I,1,2) = SUMCAP(I,1,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,1)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,1)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,1)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,1))*
     1                       (1-IGRIDSHR(I,JR,K))

            SUMCAP(I,2,2) = SUMCAP(I,2,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,2)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,2)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,2)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,2))*
     1                       (1-IGRIDSHR(I,JR,K))

            SUMCAP(I,3,2) = SUMCAP(I,3,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,3)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,3)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,3)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,3))*
     1          (1-IGRIDSHR(I,JR,K))

            SUMCAP(I,4,2) = SUMCAP(I,4,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,4)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,4)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,4)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,4))*
     1          (1-IGRIDSHR(I,JR,K))

            SUMCAP(I,5,2) = SUMCAP(I,5,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,5)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,5)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,5)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,5))*
     1         (1-IGRIDSHR(I,JR,K))

            SUMCAP(I,6,2) = SUMCAP(I,6,2) +
     1       (CAP867(I,IY,K,1)*SHARE(1,I,JR,K,6)+
     1       CAP867(I,IY,K,2)*SHARE(2,I,JR,K,6)+
     1       CAP867(I,IY,K,3)*SHARE(3,I,JR,K,6)+
     1       CAP867(I,IY,K,4)*SHARE(4,I,JR,K,6))*
     1         (1-IGRIDSHR(I,JR,K))
           ENDDO  ! end of the industry loop
          ENDDO

C***
C  calculate national capacity shares by fuel by division
C***
          DO I = 1,9
            DO J = 1,6
              IF((SUMCAP(I,J,1) + SUMCAP(I,J,2)).NE.0.0) THEN
               CAPSHR(I,J,1) = SUMCAP(I,J,1)/(SUMCAP(I,J,1)
     1                             + SUMCAP(I,J,2)) ! sales to grid
               CAPSHR(I,J,2) = SUMCAP(I,J,2)/(SUMCAP(I,J,1)
     1                              + SUMCAP(I,J,2)) ! own use generation
              ENDIF
            ENDDO
          ENDDO

C***
C   SHARE TOTAL INDUSTRIAL CAPACITY BY FUEL TO THE DIVISION LEVEL
C***
C****
          DO I = 1,9
           DO J = 1,6
            DO K = 1,2
              CAPGW(I,J,K,1) =    SUMCAP(I,J,K)
              CAPGW(11,J,K,1) = CAPGW(11,J,K,1) + CAPGW(I,J,K,1)
             ENDDO
           ENDDO
          ENDDO


C Compute summation of generation by prime mover by fuel
C*****
C  First, calculate total generation by fuel by division
C*****


      DO I = 1,11   ! division
       DO J = 1,6  ! fuel
         SUMGEN(I,J,1) = 0.0
         SUMGEN(I,J,2) = 0.0
         GENGWH(I,J,1) = 0.0
         GENGWH(I,J,2) = 0.0
       ENDDO
      ENDDO

      DO I = 1,9     ! division
        DO J = 1,6    ! internal fuel
          DO K = 1,15 ! industry
                       
           SUMGEN(I,J,1) = SUMGEN(I,J,1) +
     1        SICGEN(I,IY,K,J,1,1)+
     1        SICGEN(I,IY,K,J,2,1)+
     1        SICGEN(I,IY,K,J,3,1)

           SUMGEN(I,J,2) = SUMGEN(I,J,2) +
     1       SICGEN(I,IY,K,J,1,2)+
     1       SICGEN(I,IY,K,J,2,2)+
     1       SICGEN(I,IY,K,J,3,2)
           ENDDO  ! *** end of the industry loop ***
            GENGWH(I,J,1) = SUMGEN(I,J,1) 
            GENGWH(I,J,2) = SUMGEN(I,J,2) 
            GENGWH(11,J,1) = GENGWH(11,J,1) + GENGWH(I,J,1)
            GENGWH(11,J,2) = GENGWH(11,J,2) + GENGWH(I,J,2)
           ENDDO
      ENDDO

C*********
C SUM FUEL CONSUMPTION FOR MECS AND THE EI-867,I.E.
C  OTHER INDUSTRIAL
C********

C***
C  Total Industrial Consumption and then share by division
C***

         DO IF = 1,6
          DO IT = 1,2
            DIVFUEL(11,IF,IT) = 0.0
           ENDDO
          ENDDO
          DO IF = 1,6 ! assign coal, gas, and oil consumption
           DO IT = 1,2
             DO ID  = 1,9
             DIVFUEL(ID,IF,IT) = OTHFUEL(ID,IF,IT)
             DIVFUEL(11,IF,IT) = DIVFUEL(11,IF,IT) +
     1                            DIVFUEL(ID,IF,IT)
             ENDDO
           ENDDO
          ENDDO

C****
C  FORMAT STATEMENTS.
C****

127   FORMAT(4F10.1)
901   FORMAT(I4,5X,I1,4X,A3,2X,F7.2)
902   FORMAT(I2,2X,I1,4X,I4,1X,A2,3X,A3,2X,F7.3)
903   FORMAT(2F7.2)
904   FORMAT(2F7.2)
905   FORMAT(9F7.2)
915   FORMAT(2X, 'OWNCAP ', F8.2)
916   FORMAT(2X, 'SALECAP ', F8.2)
917   FORMAT(2X, 'CAPREG ', 6F8.2)
1001  FORMAT(2F10.1)

      RETURN
      END

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CONSUMPTION TABLES FOR INDIVIDUAL INDUSTRIES
C  MANUFACTURING-H&P,NONMANUFACTURING-H&P,MISC FEEDSTOCK,
C  ELECTRICITY GENERATED,FOOD,PAPER,CHEMICAL,GLASS,CEMENT,
C  STEEL, AND ALUMINUM
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


      SUBROUTINE SECTAB
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(APQ) !NEED INCLUDE FOR REFINING NUMBERS
      INCLUDE(INDREP)
      INCLUDE(COGEN)
      INCLUDE(INDALL)

      INTEGER I,ID,IY,IF
      REAL REFIN(15),TOTIND(15),TMSHR(15),TNSHR(15),TFSHR(6)
      REAL PETFUEL(5),ITOTAL(15),ITRENW,TOTOTH(15)
      REAL UNBENCH(15)
      REAL OTHGAS

        IY = IYR - 1989
        ITRENW = 0.0
        DO IF = 1,15
          TOTOTH(IF) = 0.0
          ITOTAL(IF) = 0.0
        ENDDO

        DO IF = 1,15
          TOTIND(IF) = 0.0
        ENDDO

       DO ID = 1,9
        ITOTAL(1) = ITOTAL(1) + QELIN(ID,IY) ! electricity
        ITOTAL(2) = ITOTAL(2) + QNGIN(ID,IY) ! natural gas

        ITOTAL(3) = ITOTAL(3) + QCLIN(ID,IY) ! steam coal
        ITOTAL(4) = ITOTAL(4) + QMCIN(ID,IY) ! met coal
        ITOTAL(5) = ITOTAL(5) + QCIIN(ID,IY) ! coke imports
        ITOTAL(6) = ITOTAL(6) + QRLIN(ID,IY) ! residual
        ITOTAL(7) = ITOTAL(7) + QDSIN(ID,IY) ! distillate

        ITOTAL(8) = ITOTAL(8) + QLGIN(ID,IY) ! lpg
        ITOTAL(9) = ITOTAL(9) + QMGIN(ID,IY) ! motor gasoline

        ITOTAL(10) = ITOTAL(10) + QSGIN(ID,IY) ! still gas
        ITOTAL(11) = ITOTAL(11) + QPCIN(ID,IY) ! petroleum coke
        ITOTAL(12) = ITOTAL(12) + QASIN(ID,IY) ! asphalt & road oil
        ITOTAL(13) = ITOTAL(13) + QPFIN(ID,IY) ! petrochem feed
        ITOTAL(14) = ITOTAL(14) + QLPIN(ID,IY) ! lease and plant gas
        ITOTAL(15) = ITOTAL(15) + QOTIN(ID,IY) ! other petroleum
     1             + QKSIN(ID,IY) ! kerosene
        ITRENW = ITRENW + QTRIN(ID,IY)  ! renewables
        OTHGAS = OTHGAS +  QNGRF(ID,IY)+
     1 CGOGQ(ID,IY,3,1) + CGOGQ(ID,IY,3,2)

       ENDDO


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   ITOTAL INDUSTRIAL CONSUMPTION- MFG, NON-MFG, AND FEEDSTOCKS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

         TOTIND(1) =  MANHP(1,IY) + NONHP(1,IY) ! electricity
         TOTIND(2) =  MANHP(2,IY) + NONHP(2,IY) + MISCFD(2,IY) +
     1                          ITOTAL(14)      ! natural gas
         TOTIND(3) =  MANHP(3,IY) + NONHP(3,IY) ! steam coal
         TOTIND(6) = MANHP(6,IY) + NONHP(4,IY)  ! residual
         TOTIND(7) = MANHP(7,IY) + NONHP(5,IY)  ! distillate
         TOTIND(8) = MANHP(8,IY) + NONHP(6,IY) + MISCFD(3,IY) ! lpg
         TOTIND(15) = MANHP(11,IY) + NONHP(8,IY) + MISCFD(6,IY) ! other pet,kero

CXXXXXXXX
C  Create Table 44, consisting of non-benchmarked manufacturing
C  heat and power, non-benchmarked non-manufacturing, non-benchmarked 
C  heat and power, feedstocks,  and present the residual between the 
C  sum of these totals less
C  the benchmarked total industrial consumption
CXXXXXXXX

C assign non-benchmarked manufacturing heat and power

          MANHPNB(1,IY) = MANHP(1,IY) ! electricity
          MANHPNB(2,IY) = MANHP(2,IY) ! natural gas
          MANHPNB(3,IY) = MANHP(3,IY) ! steam coal
          MANHPNB(4,IY) = ITOTAL(4)   ! met coal
          MANHPNB(5,IY) = ITOTAL(5) ! coke imports
          MANHPNB(6,IY) = MANHP(6,IY) ! residual oil
          MANHPNB(7,IY) = MANHP(7,IY) ! distillate
          MANHPNB(8,IY) = MANHP(8,IY) ! lpg
          MANHPNB(9,IY) = MANHP(9,IY) ! petro coke
          MANHPNB(10,IY) = MANHP(10,IY) ! still gas 
          MANHPNB(11,IY) = MANHP(11,IY) ! other petro
          MANHPNB(12,IY) = MANHP(12,IY)

          NONHPNB(1,IY) = NONHP(1,IY) ! electricity
          NONHPNB(2,IY) = NONHP(2,IY) ! natural gas
          NONHPNB(3,IY) = NONHP(3,IY) ! steam coal
          NONHPNB(4,IY) = NONHP(4,IY) ! residual oil
          NONHPNB(5,IY) = NONHP(5,IY) ! distillate
          NONHPNB(6,IY) = NONHP(6,IY) ! lpg
          NONHPNB(7,IY) = NONHP(7,IY) ! mo gas
          NONHPNB(8,IY) = NONHP(8,IY) ! petro

          MISCFDNB(1,IY) = TMISCFD(2) ! natural gas feed
          MISCFDNB(2,IY) = TMISCFD(3) ! lpg feedstock
          MISCFDNB(3,IY) = TMISCFD(4) ! asphalt
          MISCFDNB(4,IY) = TMISCFD(5) ! petrochemical
          MISCFDNB(5,IY) = TMISCFD(6) ! lubes, waxes

CXXXXX
C  CALCULATE RESIDUAL BETWEEN TOTAL INDUSTRIAL AND THE UNBENCHMARKED
C  CONSUMPTION
CXXXXX

          UNCLASS(1,IY) = ITOTAL(1) - TOTIND(1) ! electricity
          UNCLASS(2,IY) = ITOTAL(2) - TOTIND(2) ! natural gas
          UNCLASS(3,IY) = ITOTAL(3) - TOTIND(3) ! steam coal
          UNCLASS(4,IY) = ITOTAL(4) - MANHPNB(4,IY) ! met coal
          UNCLASS(5,IY) = ITOTAL(5) - MANHPNB(5,IY) ! coke import
          UNCLASS(6,IY) = ITOTAL(6) - TOTIND(6) ! residual
          UNCLASS(7,IY) = ITOTAL(7) - TOTIND(7) ! distillate
          UNCLASS(8,IY) = ITOTAL(8) - TOTIND(8) ! lpg
          UNCLASS(9,IY) = ITOTAL(9) - NONHPNB(7,IY) ! motor gas
          UNCLASS(10,IY) = ITOTAL(10) - MANHPNB(10,IY) ! still gas
          UNCLASS(11,IY) = ITOTAL(11) - MANHPNB(9,IY) ! petro coke
          UNCLASS(12,IY) = ITOTAL(12) - MISCFDNB(3,IY) ! asphalt
          UNCLASS(13,IY) = ITOTAL(13) - MISCFDNB(4,IY) ! petro feed
          UNCLASS(14,IY) = 0.0 ! lease and plant already part of natural gas
          UNCLASS(15,IY) = ITOTAL(15) - TOTIND(15) ! other petroleum

          DO I = 1,15
            UNCLASS(16,IY) = UNCLASS(16,IY) + UNCLASS(I,IY) ! total industrial
          ENDDO



CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CALCULATE SHARES FOR ALLOCATING OTHER INDUSTRIAL CONSUMPTION
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

         TMSHR(1) = MANHP(1,IY)/TOTIND(1) ! mfg elec
         TNSHR(1) = NONHP(1,IY)/TOTIND(1) ! nonmfg elec
         TMSHR(2) = MANHP(2,IY)/TOTIND(2) ! mfg nat gas
         TNSHR(2) = (NONHP(2,IY)+ITOTAL(14))/TOTIND(2) !non nat
         TFSHR(2) = MISCFD(2,IY)/TOTIND(2) ! nat gas feed
         TMSHR(3) = MANHP(3,IY)/TOTIND(3) ! mfg steam coal
         TNSHR(3) = NONHP(3,IY)/TOTIND(3) ! nonmfg steam coal
         TMSHR(6) = MANHP(6,IY)/TOTIND(6) ! mfg residual
         TNSHR(6) = NONHP(4,IY)/TOTIND(6) ! nonmfg residual
         TMSHR(7) = MANHP(7,IY)/TOTIND(7) ! mfg distillate
         TNSHR(7) = NONHP(5,IY)/TOTIND(7) ! nonmfg distillate
         TMSHR(8) = MANHP(8,IY)/TOTIND(8) ! mfg lpg h&p
         TNSHR(8) = NONHP(6,IY)/TOTIND(8) ! nonmfg lpg h&p
         TFSHR(3) = MISCFD(3,IY)/TOTIND(8) ! lpg feed
         TMSHR(15) = MANHP(11,IY)/TOTIND(15) ! mfg other petroleum,kerosene
         TNSHR(15) = NONHP(8,IY)/TOTIND(15) !nonmfg oth petroleum,kerosen
         TFSHR(6) =  MISCFD(6,IY)/TOTIND(15) !lubes, other feed

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   ALLOCATE OTHER INDUSTRIAL CONSUMPTION TO MFG, NON-MFG
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

          MANHP(1,IY)=TMSHR(1)*ITOTAL(1) ! electricity
          MANHP(2,IY)=TMSHR(2)*(ITOTAL(2)+ITOTAL(14)) ! natural gas
          MANHP(3,IY)=TMSHR(3)*ITOTAL(3) ! steam coal
          MANHP(4,IY)=ITOTAL(4) ! met coal
          MANHP(5,IY)=ITOTAL(5) ! coke imports
          MANHP(6,IY)=TMSHR(6)*ITOTAL(6) ! residual
          MANHP(7,IY)=TMSHR(7)*ITOTAL(7) ! distillate
          MANHP(8,IY)=TMSHR(8)*ITOTAL(8) ! lpg h&p
          MANHP(10,IY)=ITOTAL(10)        ! still gas
          MANHP(9,IY)=ITOTAL(11)         ! petro coke
          MANHP(11,IY) = TMSHR(15)*ITOTAL(15) ! other petroleum,kero
          MANHP(12,IY) = ITRENW          ! renewables

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR NON-MANUFACTURING HEAT & POWER.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

          NONHP(1,IY)=TNSHR(1)*ITOTAL(1)  ! electricity
          NONHP(2,IY)=TNSHR(2)*(ITOTAL(2)+ITOTAL(14)) ! nat gas
          NONHP(3,IY)=TNSHR(3)*ITOTAL(3)  ! steam coal
          NONHP(4,IY)=TNSHR(6)*ITOTAL(6)  ! residual
          NONHP(5,IY)=TNSHR(7)*ITOTAL(7)  ! distillate
          NONHP(6,IY)=TNSHR(8)*ITOTAL(8)  ! lpg h&p
          NONHP(7,IY)=ITOTAL(9)           ! mogas
          NONHP(8,IY)=TNSHR(15)*ITOTAL(15) ! other petroleum,kero

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR MISC FEEDSTOCKS.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

          MISCFD(2,IY)=TFSHR(2)*(ITOTAL(2)+ITOTAL(14)) ! nat gas feed
          MISCFD(3,IY)=TFSHR(3)*ITOTAL(8)    ! lpg feed
          MISCFD(4,IY)=ITOTAL(13)            ! petro feed
          MISCFD(5,IY)=ITOTAL(12)            ! asphalt & road oil
          MISCFD(6,IY)=TFSHR(6)*ITOTAL(15)   ! lubes et other feed

       RETURN
       END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CONSUMPTION TABLES FOR TOTAL MFG ENERGY INTENSIVE
C  Non ENERGY INTENSIVE HEAT AND POWER, AND FEEDSTOCKS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


      SUBROUTINE MFGTAB
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(APQ) !NEED INCLUDE FOR REFINING NUMBERS
      INCLUDE(INDREP)
      INCLUDE(COGEN)
      INCLUDE(INDALL)

      INTEGER I,ID,IY,IF
      REAL INTHP(15)
      REAL NONINTHP(12)
      REAL INTSHR(15),NONINTSHR(15)
      REAL NFSTKSHR(6)
      REAL METALSHR(12)
      REAL OTHMFGSHR(12)

        IY = IYR - 1989
        DO IF = 1,12
          INTHP(IF) = 0.0
          INTSHR(IF) = 0.0
          NONINTSHR(IF) = 0.0
          METALSHR(IF) = 0.0
          OTHMFGSHR(IF) = 0.0
        ENDDO


C******
C    ADD ENERGY INTENSIVE MFG CONSUMPTION BY FUEL
C******

         INTHP(1) = TFOODCON(1)+TPAPERCON(1)+TCHEMCON(1)+
     1     TGLASSCON(1)+TCEMENTCON(1)+TSTEELCON(1)+
     1     TALUMCON(1)+TREFCON(1) ! intensive electricity

         INTHP(2) = TFOODCON(2)+TPAPERCON(2)+TCHEMCON(2)+
     1     TGLASSCON(2)+TCEMENTCON(2)+TSTEELCON(2)+
     1     TALUMCON(2)+TREFCON(2)+TCHEMCON(9) ! intensive gas

         INTHP(3) = TFOODCON(3)+TPAPERCON(3)+TCHEMCON(3)+
     1     TGLASSCON(3)+TCEMENTCON(3)+TSTEELCON(3)+
     1     TALUMCON(3)+TREFCON(3) ! intensive coal

         INTHP(4) = TSTEELCON(4) ! met coal
         INTHP(5) = TSTEELCON(5) ! coke imports

         INTHP(6) = TFOODCON(4)+TPAPERCON(4)+TCHEMCON(4)+
     1     TGLASSCON(4)+TCEMENTCON(4)+TSTEELCON(6)+
     1     TALUMCON(4)+TREFCON(4) ! intensive resid

         INTHP(7) = TFOODCON(5)+TPAPERCON(5)+TCHEMCON(5)+
     1     TGLASSCON(5)+TCEMENTCON(5)+TSTEELCON(7)+
     1     TALUMCON(5)+TREFCON(5) ! intensive distillate

         INTHP(8) = TFOODCON(6)+TPAPERCON(6)+TCHEMCON(6)+
     1     TGLASSCON(6)+TCEMENTCON(6)+TSTEELCON(8)+
     1     TALUMCON(6)+TREFCON(6)+TCHEMCON(10) ! intensive lpg

c        INTHP(10) = TREFCON(7)   ! intensive still gas

c        INTHP(9) = TREFCON(8)  !intensive pet coke
         INTHP(11) = TFOODCON(7)+TPAPERCON(7)+TCHEMCON(7)+
     1     TGLASSCON(7)+TCEMENTCON(7)+TSTEELCON(9)+
     1     TALUMCON(7)+TREFCON(9)+
     1     TMISCFD(6) ! intensive other petroleum


         INTHP(12) = TFOODCON(8)+TPAPERCON(8)+TCHEMCON(8)+
     1     TGLASSCON(8)+TCEMENTCON(8)+TSTEELCON(10)+
     1     TALUMCON(8)                  ! intensive renew

C***
C   CALCULATE NON-ENERGY INTENSIVE MFG TOTAL CONSUMPTION
C   METAL BASED DURABLES, AND OTHER MANUFACTURING
C***

          DO IF = 1,12
             NONINTHP(IF) = TMANHP(IF) - INTHP(IF)
           IF(NONINTHP(IF).GT.0.0000001) THEN
             METALSHR(IF) = METBASED(IF,IY)/NONINTHP(IF)
             OTHMFGSHR(IF) = OTHMFG(IF,IY)/NONINTHP(IF)
           ENDIF
          ENDDO

C******
C   TAKE ENERGY INTENSIVE SHARE OF TOTAL UNBENCHMARKED
C   MFG ENERGY CONSUMPTION BY FUEL
C******
           INTSHR(1) = INTHP(1)/(TMANHP(1)+TREFCON(1))
           INTSHR(2) = INTHP(2)/(TMANHP(2)+TMISCFD(2)+TREFCON(2))
           INTSHR(3) =  INTHP(3)/(TMANHP(3)+TREFCON(3))
           INTSHR(4) = 1.0
           INTSHR(5) = 1.0
           INTSHR(6) = INTHP(6)/(TMANHP(6)+TREFCON(4))
           INTSHR(7) = INTHP(7)/(TMANHP(7)+TREFCON(5))
           INTSHR(8) =  INTHP(8)/(TMANHP(8)+TMISCFD(3)+TREFCON(6))
           INTSHR(9) = 1.0
           INTSHR(11) =  INTHP(11)/(TMANHP(11)+TREFCON(9)+
     1                                TMISCFD(6))
           INTSHR(12) =  INTHP(12)/TMANHP(12)


C****
C   NON ENERGY INTENSIVE SHARE OF TOTAL UNBENCHMARKED
C   MFG CONSUMPTION
C****
          DO IF = 1,12
           NONINTSHR(IF) = 1 - INTSHR(IF)
          ENDDO

C***
C   CALCULATE TOTAL ENERGY INTENSIVE MFG CONSUMPTION
C   AND NON ENERGY INTENSIVE MFG CONSUMPTION (BENCHMARKED
C   TOTAL)
C***

           INTMFG(1,IY) = INTSHR(1)*MANHP(1,IY)
           NONINTMFG(1,IY) = NONINTSHR(1)*MANHP(1,IY)

           INTMFG(2,IY) = INTSHR(2)*(MANHP(2,IY)+MISCFD(2,IY))
           NONINTMFG(2,IY) = NONINTSHR(2)*(MANHP(2,IY)
     1                                     + MISCFD(2,IY))

          DO IF = 3,7
           INTMFG(IF,IY) = INTSHR(IF)*MANHP(IF,IY)
           NONINTMFG(IF,IY) = NONINTSHR(IF)*MANHP(IF,IY)
          ENDDO

           INTMFG(8,IY) = INTSHR(8)*(MANHP(8,IY)+MISCFD(3,IY))
           NONINTMFG(8,IY) = NONINTSHR(8)*(MANHP(8,IY)
     1                                  +MISCFD(3,IY))

           INTMFG(11,IY) = INTSHR(11)*(MANHP(11,IY)+MISCFD(6,IY))
           NONINTMFG(11,IY) = NONINTSHR(11)*(MANHP(11,IY)+
     1                                     MISCFD(6,IY))

           INTMFG(12,IY) = INTSHR(12)*MANHP(12,IY)
           NONINTMFG(12,IY) = NONINTSHR(12)*MANHP(12,IY)

           INTMFG(9,IY) = MANHP(9,IY)
           INTMFG(10,IY) = MANHP(10,IY)
C***
C  USING METAL BASED DURABLE AND OTHER MANUFACTURING SHARES
C  OF TOTAL NON-INTENSIVE MFG CONSUMPTION, CALCULATE
C  BENCHMARKED TOTALS FOR THESE SUBGROUPS
C***
c           DO IF = 1,12
c             METBASED(IF,IY) = METALSHR(IF)*NONINTMFG(IF,IY)
c             OTHMFG(IF,IY) = OTHMFGSHR(IF)*NONINTMFG(IF,IY)
c           ENDDO

       RETURN
       END
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C  CONSUMPTION TABLES FOR INDIVIDUAL INDUSTRIES
C  MANUFACTURING-H&P,NONMANUFACTURING-H&P,MISC FEEDSTOCK,
C  ELECTRICITY GENERATED,FOOD,PAPER,CHEMICAL,GLASS,CEMENT,
C  STEEL, AND ALUMINUM,METAL BASED DURABLES, OTHER MANUFACTURING
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

      SUBROUTINE CONTAB
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(APQ) !NEED INCLUDE FOR REFINING NUMBERS
      INCLUDE(INDREP)
      INCLUDE(INDALL)

      INTEGER IF,ID,IY

        IY = IYR - 1989

        IF (INDNUM.EQ.1) THEN
          DO IF=1,6
            TMISCFD(IF)=0.0
          ENDDO
          DO IF=1,10
          ENDDO

          DO IF=1,12
            TMANHP(IF)=0.0
          ENDDO

          DO IF=1,8
           TNONHP(IF)=0.0
          ENDDO

          DO IF=1,12
            TFOODCON(IF)=0.0
            TREFCON(IF)=0.0
            TMANHP(IF)=0.0
            TPAPERCON(IF)=0.0
            TCHEMCON(IF)=0.0
            TGLASSCON(IF)=0.0
            TSTEELCON(IF)=0.0
            TCEMENTCON(IF)=0.0
            TALUMCON(IF)=0.0
          ENDDO
 
          DO IF = 1,12
            METBASED(IF,IY) = 0.0
            OTHMFG(IF,IY) = 0.0
          ENDDO

        ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR MANUFACTURING HEAT & POWER.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

        IF (INDDIR.GE.7.AND.INDDIR.LE.15) THEN
          TMANHP(1)=QTYMAIN(1,5)+TMANHP(1) !electricity
          TMANHP(2)=QTYMAIN(3,5)+QTYMAIN(4,5)+TMANHP(2) ! nat gas h&p
          TMANHP(3)=QTYMAIN(7,5)+TMANHP(3) ! steam coal
          TMANHP(4)=QTYMAIN(8,5)+TMANHP(4) ! met coal
          TMANHP(5)=QTYMAIN(9,5)+TMANHP(5) ! coke imports
          TMANHP(6)=QTYMAIN(10,5)+TMANHP(6) ! residual
          TMANHP(7)=QTYMAIN(11,5)+TMANHP(7) ! distillate
          TMANHP(8)=QTYMAIN(12,5)+TMANHP(8) ! lpg h&p
          TMANHP(9)=QTYMAIN(16,5)+TMANHP(9) ! petroleum coke
          TMANHP(10)=QTYMAIN(15,5)+TMANHP(10) ! still gas
          TMANHP(11)=QTYMAIN(22,5)+TMANHP(11) ! other petroleum
     1              +  QTYMAIN(20,5)          ! kerosene

          TMANHP(12)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TMANHP(12) ! renewables

        ENDIF

         IF(INDDIR.EQ.14) THEN ! METAL BASED DURABLES
          METBASED(1,IY) = QTYMAIN(1,5)+METBASED(1,IY) !electricity
          METBASED(2,IY) = QTYMAIN(3,5)+QTYMAIN(4,5)+METBASED(2,IY) ! nat gas h&p
          METBASED(3,IY) = QTYMAIN(7,5)+METBASED(3,IY) ! steam coal
          METBASED(4,IY) = QTYMAIN(8,5)+ METBASED(4,IY)! met coal
          METBASED(5,IY) = QTYMAIN(9,5)+METBASED(5,IY) ! coke imports
          METBASED(6,IY) = QTYMAIN(10,5)+METBASED(6,IY) ! residual
          METBASED(7,IY) = QTYMAIN(11,5)+METBASED(7,IY) ! distillate
          METBASED(8,IY) = QTYMAIN(12,5)+METBASED(8,IY) ! lpg h&p
          METBASED(9,IY) = QTYMAIN(16,5)+METBASED(9,IY) ! petroleum coke
          METBASED(10,IY) = QTYMAIN(15,5)+METBASED(10,IY) ! still gas
          METBASED(11,IY) = QTYMAIN(22,5)+METBASED(11,IY) ! other petroleum
     1              +  QTYMAIN(20,5)          ! kerosene

          METBASED(12,IY) = QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+METBASED(12,IY) ! renewables
        ENDIF
           
         IF(INDDIR.EQ.15) THEN ! OTHER MANUFACTURING
          OTHMFG(1,IY) = QTYMAIN(1,5)+OTHMFG(1,IY) !electricity
          OTHMFG(2,IY) = QTYMAIN(3,5)+QTYMAIN(4,5)+OTHMFG(2,IY) ! nat gas h&p
          OTHMFG(3,IY) = QTYMAIN(7,5)+OTHMFG(3,IY) ! steam coal
          OTHMFG(4,IY) = QTYMAIN(8,5)+OTHMFG(4,IY) ! met coal
          OTHMFG(5,IY) = QTYMAIN(9,5)+OTHMFG(5,IY) ! coke imports
          OTHMFG(6,IY) = QTYMAIN(10,5)+OTHMFG(6,IY) ! residual
          OTHMFG(7,IY) = QTYMAIN(11,5)+OTHMFG(7,IY) ! distillate
          OTHMFG(8,IY) = QTYMAIN(12,5)+OTHMFG(8,IY) ! lpg h&p
          OTHMFG(9,IY) = QTYMAIN(16,5)+OTHMFG(9,IY) ! petroleum coke
          OTHMFG(10,IY) = QTYMAIN(15,5)+OTHMFG(10,IY) ! still gas
          OTHMFG(11,IY) = QTYMAIN(22,5)+OTHMFG(11,IY) ! other petroleum
     1              +  QTYMAIN(20,5)          ! kerosene

          OTHMFG(12,IY) = QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+OTHMFG(12,IY) ! renewables
        ENDIF


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR NON-MANUFACTURING HEAT & POWER.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
        IF (INDDIR.LT.7) THEN
          TNONHP(1)=QTYMAIN(1,5)+TNONHP(1) ! electricity
          TNONHP(2)=QTYMAIN(3,5)+QTYMAIN(4,5)+TNONHP(2) ! nat gas h&p
          TNONHP(3)=QTYMAIN(7,5)+TNONHP(3) ! steam coal
          TNONHP(4)=QTYMAIN(10,5)+TNONHP(4) ! residual
          TNONHP(5)=QTYMAIN(11,5)+TNONHP(5) ! distillate
          TNONHP(6)=QTYMAIN(12,5)+TNONHP(6) ! lpg h&p
          TNONHP(7)=QTYMAIN(14,5)+TNONHP(7) ! motor gasoline
          TNONHP(8)=QTYMAIN(22,5)+TNONHP(8) ! other petroleum
     1             +QTYMAIN(20,5)           ! kerosene
        ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR MISC FEEDSTOCKS.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


          TMISCFD(2)=QTYMAIN(5,5)+TMISCFD(2) ! natural gas feed
          TMISCFD(3)=QTYMAIN(13,5)+TMISCFD(3) ! lpg feedstock
          TMISCFD(4)=QTYMAIN(19,5)+TMISCFD(4) ! petrochemical feed
          TMISCFD(5)=QTYMAIN(17,5)+TMISCFD(5) ! asphalt & road oil
          TMISCFD(6)=QTYMAIN(18,5)+QTYMAIN(21,5)+TMISCFD(6) !lubes, other feed


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     CONSUMPTION TABLE FOR THE REFINING HEAT & POWER
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

        IF(INDDIR.EQ.1)THEN !INDDIR NOT IN ENPROD FOR REFINING
          DO ID=1,9         !SO WE ADD EACH YEAR WHEN INDUSTRY 1
           TREFCON(1)=TREFCON(1)+QELRF(ID,IY) ! electricity
           TREFCON(2)=TREFCON(2)+QNGRF(ID,IY) ! nat gas h&p
           TREFCON(3)=TREFCON(3)+QCLRF(ID,IY) ! steam coal
           TREFCON(4)=TREFCON(4)+QRLRF(ID,IY) ! residual
           TREFCON(5)=TREFCON(5)+QDSRF(ID,IY) ! distillate
           TREFCON(6)=TREFCON(6)+QLGRF(ID,IY) ! lpg h&p
           TREFCON(7)=TREFCON(7)+QSGRF(ID,IY) ! still gas
           TREFCON(8)=TREFCON(8)+QPCRF(ID,IY) ! petroleum coke
           TREFCON(9)=TREFCON(9)+QOTRF(ID,IY) ! other petroleum
         ENDDO
        ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR FOOD.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

       IF (INDDIR.EQ.7) THEN
          TFOODCON(1)=QTYMAIN(1,5)+TFOODCON(1) ! purchased elec
          TFOODCON(2)=QTYMAIN(3,5)+TFOODCON(2)+QTYMAIN(4,5)+QTYMAIN(5,5) !nat gas
          TFOODCON(3)=QTYMAIN(7,5)+TFOODCON(3) ! steam coal
          TFOODCON(4)=QTYMAIN(10,5)+TFOODCON(4) ! residual
          TFOODCON(5)=QTYMAIN(11,5)+TFOODCON(5) ! distillate
          TFOODCON(6)=QTYMAIN(12,5)+TFOODCON(6)+QTYMAIN(13,5) ! lpg
          TFOODCON(7)=QTYMAIN(22,5)+TFOODCON(7) ! oth petroleum
          TFOODCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TFOODCON(8) ! renewables
      ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR PAPER.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

       IF (INDDIR.EQ.8) THEN
          TPAPERCON(1)=QTYMAIN(1,5)+TPAPERCON(1) ! purchased elec
          TPAPERCON(2)=QTYMAIN(3,5)+TPAPERCON(2)+QTYMAIN(4,5)
     1               +QTYMAIN(5,5) !nat gas
          TPAPERCON(3)=QTYMAIN(7,5)+TPAPERCON(3) ! steam coal
          TPAPERCON(4)=QTYMAIN(10,5)+TPAPERCON(4) ! residual
          TPAPERCON(5)=QTYMAIN(11,5)+TPAPERCON(5) ! distillate
          TPAPERCON(6)=QTYMAIN(12,5)+TPAPERCON(6)+QTYMAIN(13,5) ! lpg
          TPAPERCON(7)=QTYMAIN(22,5)+TPAPERCON(7) ! oth petroleum
          TPAPERCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TPAPERCON(8) ! renewables

      ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR bulk CHEMICALS.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
         IF (INDDIR.EQ.9) THEN
          TCHEMCON(1)=QTYMAIN(1,5)+TCHEMCON(1)!electricity
          TCHEMCON(2)=QTYMAIN(3,5)+TCHEMCON(2)+QTYMAIN(4,5)!nat gas h&p
          TCHEMCON(3)=QTYMAIN(7,5)+TCHEMCON(3)!steam coal
          TCHEMCON(4)=QTYMAIN(10,5)+TCHEMCON(4)!residual
          TCHEMCON(5)=QTYMAIN(11,5)+TCHEMCON(5)!distillate
          TCHEMCON(6)=QTYMAIN(12,5)+TCHEMCON(6)!lpg h&p
          TCHEMCON(7)=QTYMAIN(22,5)+TCHEMCON(7)!oth petroleum
          TCHEMCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TCHEMCON(8)!renewables
          TCHEMCON(9)=QTYMAIN(5,5)+TCHEMCON(9) ! nat gas feedstock
          TCHEMCON(10)=QTYMAIN(13,5)+TCHEMCON(10) !lpg feedstock
          TCHEMCON(11)=QTYMAIN(19,5)+TCHEMCON(11) !petrochemical feedstock
          TCHEMCON(12)=QTYMAIN(21,5)+TCHEMCON(12) !Other petroleum feedstock
       ENDIF


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR GLASS.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

       IF (INDDIR.EQ.10) THEN
          TGLASSCON(1)=QTYMAIN(1,5)+TGLASSCON(1)  !electricity
          TGLASSCON(2)=QTYMAIN(3,5)+TGLASSCON(2)+QTYMAIN(4,5)
     1                   +QTYMAIN(5,5) !nat gas
          TGLASSCON(3)=QTYMAIN(7,5)+TGLASSCON(3) ! steam coal
          TGLASSCON(4)=QTYMAIN(10,5)+TGLASSCON(4) ! residual
          TGLASSCON(5)=QTYMAIN(11,5)+TGLASSCON(5) ! distillate
          TGLASSCON(6)=QTYMAIN(12,5)+TGLASSCON(6)+QTYMAIN(13,5) ! lpg
          TGLASSCON(7)=QTYMAIN(22,5)+TGLASSCON(7) ! oth petroleum
          TGLASSCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TGLASSCON(8) ! renewables
       ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR CEMENT.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

       IF (INDDIR.EQ.11) THEN
          TCEMENTCON(1)=QTYMAIN(1,5)+TCEMENTCON(1) ! electricity
          TCEMENTCON(2)=QTYMAIN(3,5)+TCEMENTCON(2)+QTYMAIN(4,5)+
     1                  QTYMAIN(5,5) !nat gas
          TCEMENTCON(3)=QTYMAIN(7,5)+TCEMENTCON(3) ! steam coal
          TCEMENTCON(4)=QTYMAIN(10,5)+TCEMENTCON(4) ! residual
          TCEMENTCON(5)=QTYMAIN(11,5)+TCEMENTCON(5) ! distillate
          TCEMENTCON(6)=QTYMAIN(12,5)+TCEMENTCON(6)+QTYMAIN(13,5) ! lpg
          TCEMENTCON(7)=QTYMAIN(22,5)+TCEMENTCON(7) ! oth petroleum
          TCEMENTCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TCEMENTCON(8) ! renewables
       ENDIF


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR IRON AND STEEL.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

       IF (INDDIR.EQ.12) THEN
          TSTEELCON(1)=QTYMAIN(1,5)+TSTEELCON(1) ! electricity
          TSTEELCON(2)=QTYMAIN(3,5)+TSTEELCON(2)+QTYMAIN(4,5)
     1               +QTYMAIN(5,5) !nat gas
          TSTEELCON(3)=QTYMAIN(7,5)+TSTEELCON(3) ! steam coal
          TSTEELCON(4)=QTYMAIN(8,5)+TSTEELCON(4) ! met coal
          TSTEELCON(5)=QTYMAIN(9,5)+TSTEELCON(5) ! coke imports
          TSTEELCON(6)=QTYMAIN(10,5)+TSTEELCON(6) ! residual
          TSTEELCON(7)=QTYMAIN(11,5)+TSTEELCON(7) ! distillate
          TSTEELCON(8)=QTYMAIN(12,5)+TSTEELCON(8)+QTYMAIN(13,5) !lpg
          TSTEELCON(9)=QTYMAIN(22,5)+TSTEELCON(9) ! oth petroleum
c         TSTEELCON(10)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
c    1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
c    1  QTYRENW(8,5)+TSTEELCON(10) ! renewables
          TSTEELCON(10)=QTYINTR(2,5)  ! coke oven gas
     1 +                QTYINTR(3,5)  ! blast furnace gas
     1 +                TSTEELCON(10)
       ENDIF

CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C   CONSUMPTION TABLE FOR ALUMINUM.
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

         IF (INDDIR.EQ.13) THEN
          TALUMCON(1)=QTYMAIN(1,5)+TALUMCON(1) ! electricity
          TALUMCON(2)=QTYMAIN(3,5)+TALUMCON(2)+QTYMAIN(4,5)+QTYMAIN(5,5) !nat gs
          TALUMCON(3)=QTYMAIN(7,5)+TALUMCON(3) ! steam coal
          TALUMCON(4)=QTYMAIN(10,5)+TALUMCON(4) ! residual
          TALUMCON(5)=QTYMAIN(11,5)+TALUMCON(5) ! distillate
          TALUMCON(6)=QTYMAIN(12,5)+TALUMCON(6)+QTYMAIN(13,5) !lpg
          TALUMCON(7)=QTYMAIN(22,5)+TALUMCON(7) ! oth petroleum
          TALUMCON(8)=QTYRENW(1,5)+QTYRENW(2,5)+QTYRENW(3,5)
     1 +QTYRENW(4,5)+QTYRENW(5,5)+QTYRENW(6,5)+QTYRENW(7,5)+
     1  QTYRENW(8,5)+TALUMCON(8) ! renewables
        ENDIF


10    CONTINUE
      RETURN
      END


CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 
C Call system to execute korn shell script that will
c run report writer(s)
C
      SUBROUTINE INDUSREPORT
      IMPLICIT NONE
      INCLUDE(PARAMETR)
      INCLUDE(NCNTRL)
      INCLUDE(INDCTRL)
      INTEGER FILE_MGR
      EXTERNAL FILE_MGR
      CHARACTER*18 FNAME
      LOGICAL NEW
 
      character*60 cmd
      logical lexist
      integer retcode,system

      IF(CURIYR.EQ.LASTYR) THEN
        inquire(file='indusreport.sh',EXIST=LEXIST)
        if(lexist) then
          write(6,*) ' Calling system to execute industrial'//
     1   ' report writer shell script.' 
          cmd='ksh indusreport.sh'
          retcode=system(cmd)
        endif
        IF(PRTDBGI.EQ.1) THEN
          close(IUNIT2,STATUS='DELETE')
          close(IUNIT3,STATUS='DELETE')
          close(IUNIT7,STATUS='DELETE')
          close(IUNIT8,STATUS='DELETE')
        ENDIF         
      ENDIF
      RETURN
      END