main.f 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594
  1. PROGRAM SCBD
  2. IMPLICIT REAL*8 (A-H,O-Z)
  3. INTEGER IT,ITMAX
  4. DOUBLE PRECISION DEMAND, QUADERR
  5. DOUBLE PRECISION MUSC, MUCE, MUSE, POPSC0, POPCE0, POPSE0, EPS
  6. COMMON /PB/ NPROB
  7. INCLUDE "param.inc"
  8. DIMENSION X(10), W(3000), IACT(51)
  9. DIMENSION XL(10), XU(10)
  10. CHARACTER LINE0,LINE1,LINE2,LINE3
  11. DIMENSION LINE0(90),LINE1(90),LINE2(90),LINE3(90)
  12. ZERO=0.0D0
  13. ONE=1.0D0
  14. TWO=2.0D0
  15. EPS = 1.0D-5
  16. ITMAX = 100
  17. CALL PARAM("scbd.dat",PSC,PCE,PSE,BB,TAUSC,TAUCE,TAUSE,
  18. 1 FSC,FCE,FSE,AA)
  19. CW = VAL * CW
  20. SC = VAL * SC
  21. ASCR = VAL * ASCR
  22. ACER = VAL * ACER
  23. ASER = VAL * ASER
  24. POPSC0 = POPSC
  25. POPCE0 = POPCE
  26. POPSE0 = POPSE
  27. DO 1, I=1,90
  28. LINE0(I)='-'
  29. LINE1(I)='='
  30. LINE2(I)='='
  31. LINE3(I)='='
  32. 1 CONTINUE
  33. LINE2(20)='N'
  34. LINE2(21)='0'
  35. LINE2(23)='T'
  36. LINE2(24)='R'
  37. LINE2(25)='A'
  38. LINE2(26)='I'
  39. LINE2(27)='N'
  40. LINE2(29)='S'
  41. LINE2(30)='E'
  42. LINE3(18)='W'
  43. LINE3(19)='I'
  44. LINE3(20)='T'
  45. LINE3(21)='H'
  46. LINE3(23)='T'
  47. LINE3(24)='R'
  48. LINE3(25)='A'
  49. LINE3(26)='I'
  50. LINE3(27)='N'
  51. LINE3(29)='S'
  52. LINE3(30)='E'
  53. C (* fixed costs, free-flow travel times *)
  54. dTse=DSQRT(dTsc*dTsc+dTce*dTce-2*dTsc*dTce*DCOS(theta))
  55. dRse=DSQRT(dRsc*dRsc+dRce*dRce-2*dRsc*dRce*DCOS(theta))
  56. Fsct=dTsc/sTsc*val
  57. Fcet=dTce/sTce*val
  58. Fset=dTse/sTse*val
  59. Fscr=dRsc/sRsc*val
  60. Fcer=dRce/sRce*val
  61. Fser=dRse/sRse*val
  62. C Fser=(theta*dRsc)/sRse*val
  63. POP = POPSC+POPCE+POPSE
  64. PRINT '(6F9.2)', FSCT, FCET, FSET, FSCR, FCER, FSER
  65. C ------------------------
  66. C Head of the output table
  67. C ------------------------
  68. PRINT '(90A)', LINE1
  69. WRITE (*, '(3X,A10,9X,A15,22X,A15)') 'ADM REGIME','TRAIN','ROADS'
  70. PRINT '(90A)', LINE0
  71. WRITE (*, '(16X,4A8,5X,4A8)') 'SC','CE','SE','AGR',
  72. & 'SC','CE','SE','AGR'
  73. PRINT '(90A)', LINE2
  74. C ------------------------
  75. C 1 -- COMPUTE THE OPTIMUM
  76. C ------------------------
  77. ID=1
  78. IT = 0
  79. 305 CONTINUE
  80. CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
  81. 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)
  82. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  83. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  84. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  85. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  86. C1R=FSCR+ASCR*(POPSC-USCT)
  87. C2R=FCER+ACER*(POPCE-UCET)
  88. C3R=FSER+ASER*(POPSE-USET)
  89. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  90. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  91. POPSCOLD = POPSC
  92. POPCEOLD = POPCE
  93. POPSEOLD = POPSE
  94. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
  95. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
  96. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
  97. ERR = ZERO
  98. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  99. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  100. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  101. IT = IT + 1
  102. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 305
  103. WRITE (*, '(A12,35X,F8.4)' ) 'Optimum', TC
  104. POPTRAIN = USCT+UCET+USET
  105. POPCAR = POP-POPTRAIN
  106. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  107. & USCT,UCET,USET,POPTRAIN,
  108. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  109. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  110. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  111. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),
  112. & PSC*USCT+PCE*UCET+PSE*USET
  113. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
  114. & (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
  115. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  116. PRINT '(90A)', LINE0
  117. C Reset population
  118. POPSC = POPSC0
  119. POPCE = POPCE0
  120. POPSE = POPSE0
  121. C ------------------------
  122. C 2 -- BETA LIMITED: BETA <= BETA_MAX
  123. C ------------------------
  124. TAUSC=ZERO
  125. TAUCE=ZERO
  126. TAUSE=ZERO
  127. PSC =ZERO
  128. PCE =ZERO
  129. BB = 1.0D0
  130. CALL BETAFIXED (FSC,FCE,AA,PSC,PCE,BB,TAUSC,TAUCE,TAUSE,
  131. 1 USCT,UCET,USET,TC)
  132. WRITE (*, '(A12,35X,F8.4)' ) 'Beta bounded',TC
  133. POPTRAIN = USCT+UCET+USET
  134. POPCAR = POP-POPTRAIN
  135. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  136. & USCT,UCET,USET,POPTRAIN,
  137. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  138. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  139. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  140. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  141. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  142. C1R=FSCR+ASCR*(POPSC-USCT)
  143. C2R=FCER+ACER*(POPCE-UCET)
  144. C3R=FSER+ASER*(POPSE-USET)
  145. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  146. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  147. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  148. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  149. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),
  150. & PSC*USCT+PCE*UCET+PSE*USET
  151. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
  152. & (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
  153. PRINT '(90A)', LINE0
  154. CC -------------------------
  155. CC 2 -- UNPRICED EQUILIBRIUM
  156. CC -------------------------
  157. ID = 2
  158. IT = 0
  159. 300 CONTINUE
  160. C PRINT*, "-->", IT, POPSC, POPCE, POPSE, ERR
  161. CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
  162. 1 ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ID)
  163. POPTRAIN = USCT+UCET+USET
  164. POPCAR = POP-POPTRAIN
  165. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  166. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  167. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  168. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  169. C1R=FSCR+ASCR*(POPSC-USCT)
  170. C2R=FCER+ACER*(POPCE-UCET)
  171. C3R=FSER+ASER*(POPSE-USET)
  172. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  173. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  174. POPSCOLD = POPSC
  175. POPCEOLD = POPCE
  176. POPSEOLD = POPSE
  177. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
  178. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
  179. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
  180. ERR = ZERO
  181. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  182. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  183. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  184. IT = IT + 1
  185. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 300
  186. WRITE (*, '(A12,35X,F8.4)' ) 'Unpriced', TC
  187. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  188. & USCT,UCET,USET,POPTRAIN,
  189. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  190. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Costs',
  191. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  192. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  193. PRINT '(90A)', LINE0
  194. C Reset population
  195. POPSC = POPSC0
  196. POPCE = POPCE0
  197. POPSE = POPSE0
  198. CC -----------------------
  199. CC 2 -- PRICED EQUILIBRIUM
  200. CC -----------------------
  201. C TAUSC= ZERO
  202. C TAUCE= ZERO
  203. C TAUSE= ZERO
  204. C PSC = -0.97D0
  205. C PCE = -0.97D0
  206. C BB = 0.74D0
  207. C PRINT*, '---------PRICED EQUIL'
  208. C CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,AA,
  209. C 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
  210. C WRITE (*,'(4F9.4)') TC, USCT,UCET,USET
  211. CC -----------------------
  212. CC 2 -- ROAD PROFIT
  213. CC -----------------------
  214. IT = 0
  215. 310 CONTINUE
  216. CALL PRFROAD (PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
  217. 1 ZERO,ZERO,ZERO,TAUSC,TAUCE,TAUSE)
  218. C WRITE (*,'(8F9.4)') TC, USCT,UCET,USET,PRFR,TAUSC,TAUCE,TAUSE
  219. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  220. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  221. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  222. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  223. C1R=FSCR+ASCR*(POPSC-USCT)
  224. C2R=FCER+ACER*(POPCE-UCET)
  225. C3R=FSER+ASER*(POPSE-USET)
  226. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  227. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  228. POPSCOLD = POPSC
  229. POPCEOLD = POPCE
  230. POPSEOLD = POPSE
  231. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
  232. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
  233. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T)
  234. ERR = ZERO
  235. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  236. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  237. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  238. IT = IT + 1
  239. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 310
  240. WRITE (*, '(A12,35X,F8.4)' ) 'Road prf', TC
  241. POPTRAIN = USCT+UCET+USET
  242. POPCAR = POP-POPTRAIN
  243. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  244. & USCT,UCET,USET,POPTRAIN,
  245. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  246. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  247. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  248. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR
  249. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  250. PRINT '(90A)', LINE0
  251. C Reset population
  252. POPSC = POPSC0
  253. POPCE = POPCE0
  254. POPSE = POPSE0
  255. CC --------------------
  256. CC 2 -- TRAIN PROFIT
  257. CC --------------------
  258. IT = 0
  259. 320 CONTINUE
  260. CALL PRFTRAIN (PRFT,TC,USCT,UCET,USET,FSC,FCE,AA,
  261. 1 PSC,PCE,BB,ZERO,ZERO,ZERO)
  262. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  263. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  264. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  265. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  266. C1R=FSCR+ASCR*(POPSC-USCT)
  267. C2R=FCER+ACER*(POPCE-UCET)
  268. C3R=FSER+ASER*(POPSE-USET)
  269. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  270. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  271. POPSCOLD = POPSC
  272. POPCEOLD = POPCE
  273. POPSEOLD = POPSE
  274. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T + PSC)
  275. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T + PCE)
  276. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T + PSC + PCE )
  277. ERR = ZERO
  278. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  279. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  280. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  281. IT = IT + 1
  282. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 320
  283. WRITE (*, '(A12,35X,F8.4)' ) 'Train prf', TC
  284. POPTRAIN = USCT+UCET+USET
  285. POPCAR = POP-POPTRAIN
  286. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  287. & USCT,UCET,USET,POPTRAIN,
  288. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  289. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  290. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  291. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
  292. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  293. PRINT '(90A)', LINE0
  294. C Reset population
  295. POPSC = POPSC0
  296. POPCE = POPCE0
  297. POPSE = POPSE0
  298. CC --------------------
  299. CC 2 -- SEMI-PUBLIC
  300. CC --------------------
  301. PSC = ZERO
  302. PCE = ZERO
  303. PSE = ZERO
  304. IT = 0
  305. 330 CONTINUE
  306. CALL SEMIPUBLIC (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
  307. 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
  308. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  309. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  310. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  311. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  312. C1R=FSCR+ASCR*(POPSC-USCT)
  313. C2R=FCER+ACER*(POPCE-UCET)
  314. C3R=FSER+ASER*(POPSE-USET)
  315. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  316. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  317. POPSCOLD = POPSC
  318. POPCEOLD = POPCE
  319. POPSEOLD = POPSE
  320. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T+PSC)
  321. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T+PCE)
  322. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T+PSC+PCE)
  323. ERR = ZERO
  324. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  325. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  326. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  327. IT = IT + 1
  328. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 330
  329. WRITE (*, '(A12,35X,F8.4)' ) 'Semi-pub', TC
  330. POPTRAIN = USCT+UCET+USET
  331. POPCAR = POP-POPTRAIN
  332. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  333. & USCT,UCET,USET,POPTRAIN,
  334. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  335. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  336. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  337. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
  338. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR
  339. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  340. PRINT '(90A)', LINE0
  341. C Reset population
  342. POPSC = POPSC0
  343. POPCE = POPCE0
  344. POPSE = POPSE0
  345. CC --------------------
  346. CC 2 -- DUOPOLY
  347. CC --------------------
  348. IT = 0
  349. 340 CONTINUE
  350. CALL DUOPOLY (PRFT,PRFR,TC,USCT,UCET,USET,FSC,FCE,AA,
  351. 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE)
  352. C1T=FSCT+CW/(TWO*FSC)+ASCT*(USCT+USET)/FSC
  353. C2T=FCET+CW/(TWO*FCE)+ACET*(UCET+USET)/FCE
  354. C3T=C1T+C2T-AA*CW/(TWO*FSC)+(ONE-AA)*SC
  355. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  356. C1R=FSCR+ASCR*(POPSC-USCT)
  357. C2R=FCER+ACER*(POPCE-UCET)
  358. C3R=FSER+ASER*(POPSE-USET)
  359. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  360. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  361. POPSCOLD = POPSC
  362. POPCEOLD = POPCE
  363. POPSEOLD = POPSE
  364. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T+PSC)
  365. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T+PCE)
  366. POPSE = DEMAND(POPSE0, MUSE , FSCT+FCET, C3T+PSC+PCE)
  367. ERR = ZERO
  368. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  369. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  370. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  371. IT = IT + 1
  372. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 340
  373. WRITE (*, '(A12,35X,F8.4)' ) 'Duopoly', TC
  374. POPTRAIN = USCT+UCET+USET
  375. POPCAR = POP-POPTRAIN
  376. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  377. & USCT,UCET,USET,POPTRAIN,
  378. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  379. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  380. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  381. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB*(PSC+PCE),PRFT
  382. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,PRFR
  383. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  384. PRINT '(90A)', LINE3
  385. WRITE (*, '(16X,4A8,5X,4A8)') 'SC','CE','SE','AGR',
  386. & 'SC','CE','SE','AGR'
  387. PRINT '(90A)', LINE0
  388. C Reset population
  389. POPSC = POPSC0
  390. POPCE = POPCE0
  391. POPSE = POPSE0
  392. C ---------------------------------------------
  393. C 1 -- COMPUTE THE OPTIMUM WITH DIRECT TRAIN SE
  394. C ---------------------------------------------
  395. ID=10
  396. IT = 0
  397. 400 CONTINUE
  398. CALL OPTIMUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
  399. 1 PSC,PCE,BB,TAUSC,TAUCE,TAUSE,ID)
  400. C1T=FSCT+CW/(TWO*FSC)+ASCT*USCT/FSC
  401. C2T=FCET+CW/(TWO*FCE)+ACET*UCET/FCE
  402. C3T=FSET+CW/(TWO*FSE)+ASET*USET/FCE
  403. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  404. C1R=FSCR+ASCR*(POPSC-USCT)
  405. C2R=FCER+ACER*(POPCE-UCET)
  406. C3R=FSER+ASER*(POPSE-USET)
  407. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  408. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  409. POPSCOLD = POPSC
  410. POPCEOLD = POPCE
  411. POPSEOLD = POPSE
  412. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
  413. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
  414. POPSE = DEMAND(POPSE0, MUSE , FSET, C3T)
  415. ERR = ZERO
  416. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  417. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  418. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  419. IT = IT + 1
  420. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 400
  421. WRITE (*, '(A12,35X,F8.4)' ) 'Optimum', TC
  422. POPTRAIN = USCT+UCET+USET
  423. POPCAR = POP-POPTRAIN
  424. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  425. & USCT,UCET,USET,POPTRAIN,
  426. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  427. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Costs',
  428. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  429. WRITE (*, '(11X,A5,4F8.2)') 'Fares',PSC,PCE,BB,
  430. & PSC*USCT+PCE*UCET+PSE*USET
  431. WRITE (*, '(11X,A5,37X,4F8.2)') 'Tolls',TAUSC,TAUCE,TAUSE,
  432. & (POPSC-USCT)*TAUSC+(POPCE-UCET)*TAUCE+(POPSE-USET)*TAUSE
  433. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  434. PRINT '(90A)', LINE0
  435. C Reset population
  436. POPSC = POPSC0
  437. POPCE = POPCE0
  438. POPSE = POPSE0
  439. CC ----------------------------------------------
  440. CC 2 -- UNPRICED EQUILIBRIUM WITH DIRECT TRAIN SE
  441. CC ----------------------------------------------
  442. ID = 11
  443. IT = 0
  444. 410 CONTINUE
  445. CALL EQUILIBRIUM (TC,USCT,UCET,USET,FSC,FCE,FSE,AA,
  446. 1 ZERO,ZERO,ZERO,ZERO,ZERO,ZERO,ID)
  447. C1T=FSCT+CW/(TWO*FSC)+ASCT*USCT/FSC
  448. C2T=FCET+CW/(TWO*FCE)+ACET*UCET/FCE
  449. C3T=FSET+CW/(TWO*FSE)+ASET*USET/FCE
  450. CT =(USCT*C1T+UCET*C2T+USET*C3T)/(USCT+UCET+USET)
  451. C1R=FSCR+ASCR*(POPSC-USCT)
  452. C2R=FCER+ACER*(POPCE-UCET)
  453. C3R=FSER+ASER*(POPSE-USET)
  454. CR =((POPSC-USCT)*C1R+(POPCE-UCET)*C2R+(POPSE-USET)*C3R)/
  455. & (POPSC+POPCE+POPSE-USCT-UCET-USET)
  456. POPSCOLD = POPSC
  457. POPCEOLD = POPCE
  458. POPSEOLD = POPSE
  459. POPSC = DEMAND(POPSC0, MUSC , FSCT, C1T)
  460. POPCE = DEMAND(POPCE0, MUCE , FCET, C2T)
  461. POPSE = DEMAND(POPSE0, MUSE , FSET, C3T)
  462. ERR = ZERO
  463. ERR = ERR + QUADERR(POPSC,POPSCOLD)
  464. ERR = ERR + QUADERR(POPCE,POPCEOLD)
  465. ERR = ERR + QUADERR(POPSE,POPSEOLD)
  466. IT = IT + 1
  467. IF(IT.LE.ITMAX.AND.ERR.GT.EPS) GOTO 410
  468. WRITE (*, '(A12,35X,F8.4)' ) 'Unpriced', TC
  469. POPTRAIN = USCT+UCET+USET
  470. POPCAR = POP-POPTRAIN
  471. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2)') 'Users',
  472. & USCT,UCET,USET,POPTRAIN,
  473. & POPSC-USCT,POPCE-UCET,POPSE-USET,POPCAR
  474. WRITE (*, '(11X,A5,4F8.2,5X,4F8.2,5X)') 'Costs',
  475. & C1T,C2T,C3T,CT,C1R,C2R,C3R,CR
  476. PRINT*, 'Populations --> ', POPSC, POPCE, POPSE, IT
  477. PRINT '(90A)', LINE1
  478. C Reset population (No need at the end of the program)
  479. C POPSC = POPSC0
  480. C POPCE = POPCE0
  481. C POPSE = POPSE0
  482. END
  483. FUNCTION DEMAND(POP, MU, C0, C)
  484. IMPLICIT NONE
  485. DOUBLE PRECISION DEMAND, POP, MU, C0, C
  486. C DEMAND = POP ** ( 1.0D0 - MU * ( C/C0 - 1.0D0) )
  487. DEMAND = POP * ( C/C0 ) ** ( - MU )
  488. RETURN
  489. END
  490. FUNCTION QUADERR(X1, X2)
  491. IMPLICIT NONE
  492. DOUBLE PRECISION QUADERR, X1, X2
  493. QUADERR = DSQRT( (X1-X2) ** 2 )
  494. RETURN
  495. END