maintes.f 5.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187
  1. PROGRAM REGIONTES
  2. IMPLICIT NONE
  3. INTEGER N,NOBS,NARGS,NLQ
  4. PARAMETER(N=1000)
  5. REAL*8 EMPL(N),EMPG(N),PROD(N),PRODL(N)
  6. REAL*8 TES(N,N),COEF(N,N),LQ(N)
  7. REAL*8 MATLQ(N,N),LEONTIEF(N,N),MULTIPLIERS(N)
  8. REAL*8 DELTA,BMULT,BEMPL
  9. INTEGER ORDM(N),DEBUG,LMAT
  10. CHARACTER*25 FILENAME
  11. CHARACTER*20 REGIONAME
  12. CHARACTER*40 LABELS(N)
  13. CHARACTER*5 CODES(N)
  14. CHARACTER*5 METHOD
  15. CHARACTER*6 SORT
  16. CHARACTER*10 ARGS
  17. CHARACTER*10 FMT
  18. REAL*8 EMPL09(N),EMPL30(9),EMPL1(N),EMPL2(N)
  19. REAL*8 PRODL09(N),PRODL30(N),PRODL1(N),PRODL2(N)
  20. REAL*8 F09(N),F30(N),F1(N),F2(N)
  21. INTEGER I,J
  22. ********************************
  23. REAL*8 F(N),Y(N),WORK(N),Z(N),RCOND,LL(N,N),L(N,N)
  24. REAL*8 DET, NEWPRODL(N)
  25. INTEGER IPVT(N)
  26. NARGS=IARGC()
  27. IF(NARGS.LT.1) THEN
  28. PRINT*,'YOU SHOULD PROVIDE THE INPUT FILE NAME'
  29. STOP
  30. ENDIF
  31. CALL GETARG(1,FILENAME)
  32. NOBS=N
  33. CALL INPUTDATA(FILENAME,NOBS,TES,EMPL,EMPG,PROD,
  34. & REGIONAME,DEBUG,METHOD,DELTA,LABELS,CODES,SORT)
  35. C PRINT*,'step 1'
  36. C WRITE(*,'(36F9.2)') TES(25,1:NOBS)
  37. C The command line options overwrite those
  38. C given in the input file
  39. IF(NARGS.GT.1) THEN
  40. DO 10 I=1,NARGS
  41. CALL GETARG(I,ARGS)
  42. IF(ARGS.EQ.'-L=YES') THEN
  43. LMAT=1
  44. ELSEIF(ARGS.EQ.'-L=NO') THEN
  45. LMAT=0
  46. ELSEIF(ARGS.EQ.'-d=YES') THEN
  47. DEBUG=1
  48. ELSEIF(ARGS.EQ.'-d=NO') THEN
  49. DEBUG=0
  50. ELSEIF(ARGS.EQ.'-s=LQ') THEN
  51. SORT='LQ'
  52. ELSEIF(ARGS.EQ.'-s=MULT') THEN
  53. SORT='METHOD'
  54. ELSEIF(ARGS.EQ.'-s=NONE') THEN
  55. SORT='NONE'
  56. ELSEIF(ARGS.EQ.'-m=SLQ') THEN
  57. METHOD='SLQ'
  58. ELSEIF(ARGS.EQ.'-m=CILQ') THEN
  59. METHOD='CILQ'
  60. ELSEIF(ARGS.EQ.'-m=RLQ') THEN
  61. METHOD='RLQ'
  62. ELSEIF(ARGS.EQ.'-m=CILQ') THEN
  63. METHOD='CILQ'
  64. ELSEIF(ARGS.EQ.'-m=FLQ') THEN
  65. METHOD='FLQ'
  66. ELSEIF(ARGS.EQ.'-m=NAT') THEN
  67. METHOD='NAT'
  68. ENDIF
  69. 10 CONTINUE
  70. ENDIF
  71. CALL MATCOEF(TES,PROD,COEF,NOBS,N,DEBUG)
  72. CALL LOCQ(METHOD,EMPL,EMPG,NOBS,N,DELTA,MATLQ,LQ,DEBUG)
  73. C PRINT*,'step 3'
  74. CALL REGIONAL(N,NOBS,COEF,MATLQ,LEONTIEF,MULTIPLIERS,DEBUG)
  75. C PRINT*,COEF(25,1:NOBS)
  76. C PRINT*,'step 4'
  77. NLQ=0
  78. DO I=1,NOBS
  79. IF(LQ(I).GT.1.D0) THEN
  80. NLQ=NLQ+1
  81. BEMPL=BEMPL+EMPL(I)
  82. ENDIF
  83. ENDDO
  84. BMULT=SUM(EMPL(1:NOBS))/BEMPL
  85. PRINT*, '======================================'
  86. PRINT*, 'REGION/CITY NAME: ', REGIONAME
  87. PRINT*, '--------------------------------------'
  88. PRINT '(X,A31,I3)', 'NUMBER OF SECTORS WITH LQ > 1 :', NLQ
  89. PRINT*, '--------------------------------------'
  90. PRINT '(X,A31,F7.3)', 'BASE MULTIPLIER :', BMULT
  91. PRINT*, '--------------------------------------'
  92. IF(SORT.EQ.'LQ') THEN
  93. CALL SORTRX(NOBS,LQ,ORDM)
  94. ELSEIF(SORT.EQ.'METHOD')THEN
  95. CALL SORTRX(NOBS,MULTIPLIERS,ORDM)
  96. ELSE
  97. DO I=1,NOBS
  98. ORDM(I)=NOBS-I+1
  99. ENDDO
  100. ENDIF
  101. PRINT'(18X,A6)',METHOD
  102. PRINT*,' CODES LQ MULTIP. DESCR.'
  103. PRINT*,'======================================'
  104. DO I=1,NOBS
  105. J=ORDM(NOBS-I+1)
  106. PRINT '((5X)(A4)(f6.3)(3X)(F6.3)(5X)(A35))',
  107. & CODES(J), LQ(J),MULTIPLIERS(J),LABELS(J)
  108. ENDDO
  109. PRINT*,'======================================'
  110. PRINT*
  111. IF(LMAT.EQ.1) THEN
  112. WRITE(FMT,'("("I0,"F9.3)")') NOBS
  113. PRINT*,'LEONTIEF MATRIX (I-A)^(-1)'
  114. DO I=1,NOBS
  115. WRITE(*,FMT),(LEONTIEF(I,J),J=1,NOBS)
  116. ENDDO
  117. ENDIF
  118. PRINT*
  119. ************************************************
  120. ************************************************
  121. * This part is added for computations to the
  122. * case of IDF.
  123. ************************************************
  124. ************************************************
  125. C DO I=1,NOBS
  126. C PRODL(I)=PROD(I)/EMPG(I)*EMPL(I)
  127. * PRINT '(A2,3F15.3)', CODES(I),PRODL(I),PROD(I),PROD(I)/EMPG(I)
  128. C ENDDO
  129. * LL = (I-A) and
  130. * LEONTIEF = (I-A)^-1
  131. * PRODL : the initial production
  132. * EMPL : the initial employment
  133. * NEWPRODL : the new production
  134. * NEWEMPL : the new employment
  135. *
  136. C LL=LEONTIEF
  137. C CALL DGECO(LL,N,NOBS,IPVT,RCOND,Z)
  138. C CALL DGEDI(LL,N,NOBS,IPVT,DET,WORK,01)
  139. * Now LL is the inverse of LEONTIEF
  140. CALL DGEMV('N',NOBS,NOBS,1.0D0,LL,N,PRODL,1,0.0D0,Y,1)
  141. * Y contains the final consumption
  142. * PRINT*, 'Emploi final à l échelle locale (M€)'
  143. * DO I=1,NOBS
  144. * PRINT '(F12.3)', Y(I)
  145. * ENDDO
  146. * here a test of whether the computation of
  147. * the inverse matrix are correct
  148. * CALL DGEMM('N','N',NOBS,NOBS,NOBS,1.D0,LL,N,LEONTIEF,N,0.D0,L,N)
  149. * the transport sector has an increase of 10% in final demand
  150. * PRINT '(F12.3)',Y(20)
  151. C Y(20)=1.1D0*Y(20)
  152. * PRINT '(F12.3)',Y(20)
  153. * the induced change in production is
  154. C CALL DGEMV('N',NOBS,NOBS,1.D0,LEONTIEF,N,Y,1,0.0D0,NEWPRODL,1)
  155. C DO I=1,NOBS
  156. C PRINT '(A2,",",F12.3,",",F12.3)', CODES(I),LQ(I),
  157. C & (NEWPRODL(I)-PRODL(I))/(PROD(I)/EMPG(I))
  158. C ENDDO
  159. * PRINT*, LEONTIEF(1,1:NOBS)
  160. * DO I=1,5
  161. * PRINT '(5F12.3)', LL(I,1:5)
  162. * ENDDO
  163. * PRINT*
  164. * DO I=1,5
  165. * PRINT '(5F12.3)', LEONTIEF(I,1:5)
  166. * ENDDO
  167. * PRINT*
  168. * DO I=1,5
  169. * PRINT '(5F12.3)', L(I,1:5)
  170. * ENDDO
  171. * Y(20)=Y(20)*1.1D0
  172. END