123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594 |
- PROGRAM SCBD
- IMPLICIT REAL*8 (A-H,O-Z)
- INTEGER IT,ITMAX
- DOUBLE PRECISION DEMAND, QUADERR
- DOUBLE PRECISION MUSC, MUCE, MUSE, POPSC0, POPCE0, POPSE0, EPS
- 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
- EPS = 1.0D-5
- ITMAX = 100
- 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
- POPSC0 = POPSC
- POPCE0 = POPCE
- POPSE0 = POPSE
- 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
- IT = 0
- 305 CONTINUE
- CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
- 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 305
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- 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
- IT = 0
- 300 CONTINUE
- C PRINT*, "-->", IT, POPSC, POPCE, POPSE, ERR
- 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
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 300
- 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
- WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Costs',
- & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
- PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- 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 -----------------------
- IT = 0
- 310 CONTINUE
- 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
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 310
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- CC --------------------
- CC 2 -- TRAIN PROFIT
- CC --------------------
- IT = 0
- 320 CONTINUE
- CALL PRFTRAIN (PRFT,TC,USCT,UCET,USET,FSC,FCE,AA,
- 1 PSC,PCE,BB,ZERO,ZERO,ZERO)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T + PSC)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T + PCE)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T + PSC + PCE )
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 320
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- CC --------------------
- CC 2 -- SEMI-PUBLIC
- CC --------------------
- PSC = ZERO
- PCE = ZERO
- PSE = ZERO
- IT = 0
- 330 CONTINUE
- CALL SEMIPUBLIC (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
- 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T+PSC)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T+PCE)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T+PSC+PCE)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 330
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- CC --------------------
- CC 2 -- DUOPOLY
- CC --------------------
- IT = 0
- 340 CONTINUE
- CALL DUOPOLY (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
- 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T+PSC)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T+PCE)
- POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T+PSC+PCE)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 340
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE3
- WRITE (*, '(16X,4A8,5X,4A8)') 'SC','CE','SE','AGR',
- & 'SC','CE','SE','AGR'
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- C ---------------------------------------------
- C 1 -- COMPUTE THE OPTIMUM WITH DIRECT TRAIN SE
- C ---------------------------------------------
- ID=10
- IT = 0
- 400 CONTINUE
- CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
- 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
- POPSE = DEMAND(POPSE0, MUSE , FSET, C3T)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 400
- 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
- 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*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE0
- C Reset population
- POPSC = POPSC0
- POPCE = POPCE0
- POPSE = POPSE0
- CC ----------------------------------------------
- CC 2 -- UNPRICED EQUILIBRIUM WITH DIRECT TRAIN SE
- CC ----------------------------------------------
- ID = 11
- IT = 0
- 410 CONTINUE
- CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
- 1 ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ID)
- 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)
- POPSCOLD = POPSC
- POPCEOLD = POPCE
- POPSEOLD = POPSE
- POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
- POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
- POPSE = DEMAND(POPSE0, MUSE , FSET, C3T)
- ERR = ZERO
- ERR = ERR + QUADERR(POPSC,POPSCOLD)
- ERR = ERR + QUADERR(POPCE,POPCEOLD)
- ERR = ERR + QUADERR(POPSE,POPSEOLD)
- IT = IT + 1
- IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 410
- 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
- WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
- & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
- PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
- PRINT '(90A)', LINE1
- C Reset population (No need at the end of the program)
- C POPSC = POPSC0
- C POPCE = POPCE0
- C POPSE = POPSE0
- END
- FUNCTION DEMAND(POP, MU, C0, C)
- IMPLICIT NONE
- DOUBLE PRECISION DEMAND, POP, MU, C0, C
- C DEMAND = POP ** ( 1.0D0 - MU * ( C/C0 - 1.0D0) )
- DEMAND = POP * ( C/C0 ) ** ( - MU )
- RETURN
- END
- FUNCTION QUADERR(X1, X2)
- IMPLICIT NONE
- DOUBLE PRECISION QUADERR, X1, X2
- QUADERR = DSQRT( (X1-X2) ** 2 )
- RETURN
- END
|