! OLG single sector 公共支出一定 相続税増税、消費税率にて調整 ! FORTRAN 90 PROGRAM BY K.HASHIMOTO 2000.7.13 INTEGER, PARAMETER :: lt=200,gt=3 ! lt=last time gt=generation size DOUBLE PRECISION, PARAMETER :: n=0.001 ! n=JIKO SEITYO DOUBLE PRECISION, PARAMETER :: SEIDO=0.000001 ! SHUSOKU SEIDO DOUBLE PRECISION, PARAMETER :: govi= 10.83415! 一人あたり政府支出 INTEGER t,I,J,AGE,printout DOUBLE PRECISION total,bk,ak,w,r,GOSA,vat,vst,gova,gosa2,tz DOUBLE PRECISION totaln(0:200) DOUBLE PRECISION jinko,saving,isan,ac,KS,Y,gov DOUBLE PRECISION C,U COMMON /MACRODAT/ jinko(1:200,1:3),saving(1:200,0:3),isan(0:200),AC(0:200),KS(0:200),Y(0:200),gov(0:200) COMMON /KAKEI/ c(1:200,1:3),u(1:200) ! INITIAL DATA SET PRITOUT=0 vat=0.01 vst=0.01 tz=0.2 jinko(1, 1)=0.1 jinko(2, 1)=0.1 jinko(3, 1)=0.1 DO I=1,gt DO J=2,gt jinko(I, J) = jinko(I, 1) END DO END DO DO t=3,lt-3 jinko(t+1,1)=jinko(t,1) * (1+n) DO J=2,gt jinko(t+1,J)=jinko(t+1,1) END DO END DO DO t=0,lt-3 total=0 AGE=3 DO I=1,3 total=total+jinko(t+I,AGE) AGE=AGE-1 END DO totaln(t)=total END DO ! -----------------MAIN-------------------------------------- 10 FORMAT(I4,f10.6,F10.5,f12.6) 20 FORMAT(f10.10,F12.5) 77 t=0 DO WHILE(.TRUE.) saving(1,1)=0 SAVING(1,2) = 80 SAVING(2,1) = 56.3704 isan(0)=13 saving(t+2,1)=saving(t+2,1)+isan(t)*(1-tz) CALL merrill(w,r,t,vat,tz) ! stop AK = KS(t)/totaln(t) gova=gov(t)/totaln(T) GOSA=(bK-ak)**2 ! WRITE(*,*) T,VAT,GOVA,ISAN(T) IF (GOSA.LT.SEIDO) EXIT bk=KS(t)/totaln(t) t=t+1 END DO write (*,*) vat,GOSA gosa2=(gova-govi)**2 if (gosa2.lt.0.000001) then WRITE(*,*) VAT GOTO 55 end if if (gova.gt.govi) then vat=vat-vst vst=vst/2 vat=vat+vst goto 77 end if vat=vat+vst goto 77 55 t=0 30 FORMAT(I4,f10.6,F10.5,F12.6,F12.6) OPEN(UNIT=1,IOSTAT=OS,FILE='CASE1.DAT',STATUS='NEW') DO WHILE(.TRUE.) saving(1,1)=0 SAVING(1,2) = 80 SAVING(2,1) = 56.3704 isan(0)=13 saving(t+2,1)=saving(t+2,1)+isan(t)*(1-tz) CALL merrill(w,r,t,vat,tz) ! stop AK = KS(t)/totaln(t) gova=gov(t)/totaln(T) GOSA=(bK-ak)**2 WRITE(*,30) t, AC(T)/TOTALN(T),KS(T)/totaln(t),gov(t)/totaln(t),ISAN(T) WRITE(1,30) t, AC(T)/TOTALN(T),KS(T)/totaln(t),gov(t)/totaln(t),ISAN(T) IF (GOSA.LT.SEIDO) EXIT bk=KS(t)/totaln(t) t=t+1 END DO STOP END !--------------超過需要関数---------------------------------------------------- SUBROUTINE EXD(NEW,E,MAX,MAXJ,BUNBO,t,w,r,p,vat,tz) DOUBLE PRECISION, PARAMETER :: DELTA=0.1,GANMA=0.5 !効用関数パラメータ DOUBLE PRECISION, PARAMETER :: PHI=1, ALFA=.5 !生産関数パラメータ DOUBLE PRECISION, PARAMETER :: BETA=0.3 !遺産のウェイトパラメータ INTEGER, PARAMETER :: lt=200,gt=3 DOUBLE PRECISION NEW(0:2),E(1:2) DOUBLE PRECISION CST,w,r,LQ,KQ,KD,LD,DR,DW,c1,BUNBO,MAX,kk,uc,vat,UK,TY DOUBLE PRECISION tz!相続税率 INTEGER I,J,AGE,MAXJ,t DOUBLE PRECISION LS(0:200),lbar(1:200,1:3),ti(0:200) DOUBLE PRECISION invest(1:200,1:3),wage(1:200,1:3),p(0:200) DOUBLE PRECISION zeishu(0:200),VATREV(0:200) DATA ((lbar(I,J),J=1,gt),I=1,gt) /200,200,0,200,200,0,200,200,0/ DOUBLE PRECISION jinko,saving,isan,AC,KS,Y,gov DOUBLE PRECISION C,U COMMON /MACRODAT/ jinko(1:200,1:3),saving(1:200,0:3),isan(0:200),ac(0:200),KS(0:200),Y(0:200),gov(0:200) COMMON /KAKEI/ c(1:200,1:3),u(1:200) DO I=4,lt DO J=1,gt lbar(I,J)=lbar(3,J) END DO END DO ! intial value----------------------------------- C(1, 1) = 30.36423 C(1, 2) = 70.8525 C(2, 1) = 40.36423 ty=0.1 ! ------------------------------------------------- r=NEW(1)/BUNBO w=NEW(2)/BUNBO kk=0 r=r/w w=1 IF (R.LE.0) then ! 端点解の処理 maxj=1 ! return ! end if LQ=0 KQ=0 KD=0 LD=0 DR=0 DW=0 DW=(1-ALFA)*W DR=alfa*R LQ=((DR/DW)**(1-ALFA))/PHI KQ=((DW/DR)**ALFA)/PHI P(t)=W*LQ+R*KQ DO J=t,200 P(J)= P(t) END DO AGE=gt DO I=1,gt DO AGE=1,gt WAGE(t+I,AGE)=W*lbar(t+I,AGE) END DO END DO AGE=3 DO 100 I=1,3 CST=1 c1=1 UK=0 UC=0 kk=0 ub=-1D+22 777 call life(t,I,c1,age,r,c,invest,wage,p,ganma,delta,TY,vat) kk=SAVING(T+I,3)*(1-tz) ISAN(T+1)=saving(t+1,3)*jinko(t+1,3) IF (kk.LE.0) THEN c1=c1-CST CST=CST/10 c1=c1+CST GOTO 777 END IF uc=0 DO J=1,3 uc=uc+(1+DELTA)**(-(J-1)) * C(t+I,J)**(1-1/GANMA) /(1-1/GANMA) END DO UK=((1+DELTA)**(-2))*KK**(1-1/GANMA) /(1-1/GANMA) u(t+I)=(1-BETA)*UC+beta*UK ! u(t+I)=uc IF (CST.LT.0.0000000001) GOTO 800 IF (u(T+I).LT.ub) THEN c1=c1-CST CST=CST/10 c1=c1+CST GOTO 777 END IF IF (CST.LT.0.0000000001) GOTO 800 ub=u(T + I) c1=c1+CST GOTO 777 800 AGE=AGE-1 100 CONTINUE AGE=gt AC(t)=0 ti(t)=0 LS(t)=0 KS(t)=0 VATREV(t)=0 DO I=1,3 VATREV(t)=VATREV(t)+vat*P(t)*C(t+I,AGE)*jinko(t+I,AGE) AC(t)=AC(t)+C(t+I,AGE)*jinko(t+i,age) ti(t)=ti(t)+invest(t+I,AGE)*jinko(t+i,age) LS(t)=LS(t)+lbar(t+I,AGE)*jinko(t+i,age) KS(t)=KS(t)+SAVING(t+I,AGE-1)*jinko(t+i,age) AGE=AGE-1 END DO ! ---------------tax revenue---------------------- zeishu(t)=ty*W*LS(t)+VATREV(t)+tz*ISAN(t) GOV(t)=zeishu(t)/p(t) ti(t)=ti(t)-tz*ISAN(t) Y(t)=AC(t)+ti(t)/p(t)+GOV(t) LD=LQ*Y(t) KD=KQ*Y(t) E(1)=KD-KS(t) E(2)=LD-LS(t) MAX=-1000000 MAXJ=0 DO J=1,2 IF (E(J).GT.MAX) THEN MAX=E(J) MAXJ=J END IF END DO RETURN END !---------------------LIFE CYCLE CONSUMTION PATH------------------------------- SUBROUTINE life(t,I,c1,age1,r,c,invest,wage,p,GANMA,DELTA,TY,vat) INTEGER,PARAMETER :: lt=200,gt=3 DOUBLE PRECISION delta,ganma DOUBLE PRECISION c(1:200,1:3),invest(1:200,1:3),WAGE(1:200,1:3),P(0:200) DOUBLE PRECISION c1,r,A1,ty,vat INTEGER I,t,age1,AGE,t1 DOUBLE PRECISION jinko,saving,isan,ac,KS,y COMMON /MACRODAT/ jinko(1:200,1:3),saving(1:200,0:3),isan(0:200),AC(0:200),KS(0:200),y(0:200),gov(0:200) A1=0 t1=t saving(t+i,0)=0 A1=((1+r)/(1+DELTA))**GANMA C(t+I,age1)=c1 SAVING(t+I,age1)=(1+r)*SAVING(t+I,age1-1)+(1-ty)*WAGE(t+I,age1)-(1+vat)*P(t1)*C(t+I,age1) invest(t+I,age1)=SAVING(t+I,age1)-SAVING(t+I,age1-1) DO AGE=age1,2 C(t+I,AGE+1)=A1*C(t+I,AGE)*(P(t1)/P(t1+1))**GANMA SAVING(t+I,AGE+1)=(1+r)*SAVING(t+I,AGE)+(1-ty)*WAGE(t+I,AGE+1)-(1+vat)*P(t1+1)*C(t+I,AGE+1) invest(t+I,AGE+1)=SAVING(t+I,age+1)-SAVING(t+I,age) END DO RETURN END ! ----------------- MERRILL algolism ------------------------------- SUBROUTINE merrill(w, r, t,vat,tz) DOUBLE PRECISION,parameter:: big=10**13 DOUBLE PRECISION G(0:2,0:2),E(1:2),NEW(0:2),K(1:2) DOUBLE PRECISION p(0:200) INTEGER COUNT,NLABEL,I,J,LJ,S,L(0:2),WA,t,M,J1,JM1 DOUBLE PRECISION MAX,ST,KG,w,r,vat,tz do i=0,2 L(i)=0 end do LJ=0 S=0 ST=10 K(1)=5 K(2)=5 CALL INITIAL(G,K,L,NEW) CALL EXD(NEW,E,MAX,NLABEL,ST,t,W,r,p,vat,tz) L(0)=0 LJ=0 55 COUNT=COUNT+1 KG=0 WA=0 SHU=0 SHU=G(0,0)+G(0,1)+G(0,2) IF (SHU.EQ.1) THEN WA=0 DO 60 I=0,2 IF(G(0,I).EQ.0) THEN WA=L(I)+WA IF (L(I).EQ.0) WA=WA+NLABEL END IF 60 CONTINUE END IF IF(WA.EQ.3) THEN ! write(*,*) t,e(1),e(2),st CALL RSTART(K,ST,NEW) CALL INITIAL(G,K,L,NEW) CALL EXD(NEW,E,MAX,NLABEL,ST,t,w,r,p,vat,tz) L(0)=0 LJ=0 KG=0 IF (ST.GT.big) then ! write(*,*) T,e(1),e(2),st GOTO 400 end if END IF J=0 J1=0 JM1=0 DO M=0,2 IF (NLABEL.EQ.L(M)) THEN J=M L(LJ)=NLABEL J1=J+1 JM1=J-1 IF (J.EQ.0) JM1=2 IF (J.EQ.2) J1=0 DO I=0,2 NEW(I)=G(I,J1)+G(I,JM1)-G(I,J) G(I,J)=NEW(I) END DO IF (NEW(0).EQ.0) CALL EXD(NEW,E,MAX,NLABEL,ST,t,w,r,p,vat,tz) IF (NEW(0).EQ.1) THEN DO I=1,2 KG=K(I)-G(I,J) IF (KG.GT.0) GOTO 209 END DO 209 NLABEL=I END IF LJ=M L(J)=0 GO TO 55 END IF END DO 400 RETURN END SUBROUTINE RSTART(K,ST,NEW) DOUBLE PRECISION K(1:2),ST,NEW(0:2) INTEGER I ST=ST*3 DO 30 I=1,2 K(I)=NEW(I)*3 30 CONTINUE RETURN END SUBROUTINE INITIAL(G,K,L,NEW) DOUBLE PRECISION G(0:2,0:2),NEW(0:2),K(1:2),KG INTEGER L(0:2),I,J G(0,0)=0 G(1,0)=K(1) G(2,0)=K(2) G(0,1)=1 G(0,2)=1 DO 50 I=1,2 DO 51 J=1,2 G(I,J)=G(I,0) IF (J.EQ.I) G(I,J)=G(I,0)-1 51 CONTINUE 50 CONTINUE DO 110 I=1,2 DO 100 J=1,2 KG=K(I)-G(I,J) IF (KG.GT.0) GOTO 105 100 CONTINUE 105 L(I)=I 110 CONTINUE DO 200 I=1,2 NEW(I)=G(I,0) 200 CONTINUE RETURN END