scbd/src/main.f

      PROGRAM SCBD
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON /PB/ NPROB

      INCLUDE "param.inc"
      DIMENSION X(10), W(3000), IACT(51)
      DIMENSION XL(10), XU(10)
      CHARACTER LINE0,LINE1,LINE2,LINE3
      DIMENSION LINE0(90),LINE1(90),LINE2(90),LINE3(90)
    
      ZERO=0.0D0
      ONE=1.0D0
      TWO=2.0D0

      CALL  PARAM("scbd.dat",PSC,PCE,PSE,BB,TAUSC,TAUCE,TAUSE,
     1  FSC,FCE,FSE,AA) 

      CW   = VAL * CW
      SC   = VAL * SC
      ASCR = VAL * ASCR
      ACER = VAL * ACER
      ASER = VAL * ASER


      DO 1, I=1,90
      LINE0(I)='-'
      LINE1(I)='='
      LINE2(I)='='
      LINE3(I)='='
  1   CONTINUE
      LINE2(20)='N'
      LINE2(21)='0'

      LINE2(23)='T'
      LINE2(24)='R'
      LINE2(25)='A'
      LINE2(26)='I'
      LINE2(27)='N'

      LINE2(29)='S'
      LINE2(30)='E'

      LINE3(18)='W'
      LINE3(19)='I'
      LINE3(20)='T'
      LINE3(21)='H'

      LINE3(23)='T'
      LINE3(24)='R'
      LINE3(25)='A'
      LINE3(26)='I'
      LINE3(27)='N'

      LINE3(29)='S'
      LINE3(30)='E'


C     (* fixed costs, free-flow travel times *)
      dTse=DSQRT(dTsc*dTsc+dTce*dTce-2*dTsc*dTce*DCOS(theta))
      dRse=DSQRT(dRsc*dRsc+dRce*dRce-2*dRsc*dRce*DCOS(theta))
      Fsct=dTsc/sTsc*val
      Fcet=dTce/sTce*val
      Fset=dTse/sTse*val
      Fscr=dRsc/sRsc*val
      Fcer=dRce/sRce*val
      Fser=dRse/sRse*val
C     Fser=(theta*dRsc)/sRse*val
      POP = POPSC+POPCE+POPSE
      PRINT '(6F9.2)', FSCT, FCET, FSET, FSCR, FCER, FSER 

C  ------------------------
C  Head of the output table
C  ------------------------

      PRINT '(90A)', LINE1
      WRITE (*, '(3X,A10,9X,A15,22X,A15)') 'ADM REGIME','TRAIN','ROADS'
      PRINT '(90A)', LINE0
      WRITE (*, '(16X,4A8,5X,4A8)') 'SC','CE','SE','AGR', 
     &                              'SC','CE','SE','AGR' 
      PRINT '(90A)', LINE2

C  ------------------------
C  1 -- COMPUTE THE OPTIMUM
C  ------------------------

      ID=1
      CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
     1              PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)

      WRITE (*, '(A12,35X,F8.4)' ) 'Optimum', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),
     &     PSC*USCT+PCE*UCET+PSE*USET
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
     &  (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
      PRINT '(90A)', LINE0

C  ------------------------
C  2 -- BETA LIMITED: BETA <= BETA_MAX
C  ------------------------

      TAUSC=ZERO
      TAUCE=ZERO
      TAUSE=ZERO
      PSC  =ZERO
      PCE  =ZERO
      BB = 1.0D0
      CALL BETAFIXED (FSC,FCE,AA,PSC,PCE,BB,TAUSC,TAUCE,TAUSE,
     1         USCT,UCET,USET,TC)

      WRITE (*, '(A12,35X,F8.4)' ) 'Beta bounded',TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),
     &     PSC*USCT+PCE*UCET+PSE*USET
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
     &  (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
      PRINT '(90A)', LINE0

CC  -------------------------
CC  2 -- UNPRICED EQUILIBRIUM
CC  -------------------------

      ID = 2
      CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
     1     ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ID) 
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(A12,35X,F8.4)' ) 'Unpriced', TC
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      PRINT '(90A)', LINE0

CC  -----------------------
CC  2 -- PRICED EQUILIBRIUM
CC  -----------------------

C     TAUSC= ZERO
C     TAUCE= ZERO
C     TAUSE= ZERO
C     PSC  = -0.97D0
C     PCE  = -0.97D0
C     BB   =  0.74D0
C     PRINT*, '---------PRICED EQUIL'
C     CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,AA,
C    1     PSC,PCE,BB,TAUSC,TAUCE,TAUSE) 
C     WRITE (*,'(4F9.4)') TC, USCT,UCET,USET 

CC  -----------------------
CC  2 -- ROAD PROFIT
CC  -----------------------

      CALL PRFROAD (PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
     1     ZERO,ZERO,ZERO,TAUSC,TAUCE,TAUSE) 
C     WRITE (*,'(8F9.4)') TC, USCT,UCET,USET,PRFR,TAUSC,TAUCE,TAUSE 
      WRITE (*, '(A12,35X,F8.4)' ) 'Road prf', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR
      PRINT '(90A)', LINE0

CC  --------------------
CC  2 -- TRAIN PROFIT
CC  --------------------

      CALL PRFTRAIN (PRFT,TC,USCT,UCET,USET,FSC,FCE,AA,
     1     PSC,PCE,BB,ZERO,ZERO,ZERO) 
      WRITE (*, '(A12,35X,F8.4)' ) 'Train prf', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
      PRINT '(90A)', LINE0 

CC  --------------------
CC  2 -- SEMI-PUBLIC
CC  --------------------
      PSC = ZERO
      PCE = ZERO
      PSE = ZERO
      CALL SEMIPUBLIC (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
     1                 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
      WRITE (*, '(A12,35X,F8.4)' ) 'Semi-pub', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR
      PRINT '(90A)', LINE0

CC  --------------------
CC  2 -- DUOPOLY
CC  --------------------

      CALL DUOPOLY (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
     1              PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
      WRITE (*, '(A12,35X,F8.4)' ) 'Duopoly', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE 
      C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR

      PRINT '(90A)', LINE3 
      WRITE (*, '(16X,4A8,5X,4A8)') 'SC','CE','SE','AGR', 
     &                              'SC','CE','SE','AGR' 
      PRINT '(90A)', LINE0
C  ---------------------------------------------
C  1 -- COMPUTE THE OPTIMUM WITH DIRECT TRAIN SE
C  ---------------------------------------------

      ID=10
      CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
     1              PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)

      WRITE (*, '(A12,35X,F8.4)' ) 'Optimum', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*USCT/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*UCET/FCE 
      C3T=FSET+CW/(TWO*FSE)+ASET*USET/FCE 
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB,
     &     PSC*USCT+PCE*UCET+PSE*USET
      WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
     &  (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
      PRINT '(90A)', LINE0

CC  ----------------------------------------------
CC  2 -- UNPRICED EQUILIBRIUM WITH DIRECT TRAIN SE
CC  ----------------------------------------------

      ID = 11
      CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
     1     ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ID) 
      WRITE (*, '(A12,35X,F8.4)' ) 'Unpriced', TC
      POPTRAIN = USCT+UCET+USET
      POPCAR = POP-POPTRAIN
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)')  'Users', 
     &   USCT,UCET,USET,POPTRAIN,
     &   POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR 

      C1T=FSCT+CW/(TWO*FSC)+ASCT*USCT/FSC
      C2T=FCET+CW/(TWO*FCE)+ACET*UCET/FCE 
      C3T=FSET+CW/(TWO*FSE)+ASET*USET/FCE 
      CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
      C1R=FSCR+ASCR*(POPSC-USCT)
      C2R=FCER+ACER*(POPCE-UCET)
      C3R=FSER+ASER*(POPSE-USET)
      CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
     &    (POPSC+POPCE+POPSE-USCT-UCET-USET) 
      WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)')  'Costs', 
     &   C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
      PRINT '(90A)', LINE1


      END