subroutine aggregate_cex Use declarations ! program CEX8194.FOR !********************************************************************** ! This program compares CEX and NIPA aggregates over time !********************************************************************** !********************************************************************* ! input files: ! ! 10 ffile801,... cex files from EXTRFAM.FOR ! 11 nipa8194 file with NIPA values from NIPAEXTR.FOR ! ! output files: ! ! 20 cex8194.rep report file !********************************************************************* parameter begyear = 1981 parameter endyear = 2001 parameter numfiles = 82 !********************************************************************* ! input variables from cex (see EXTRFAM.FOR) !********************************************************************* integer newid character*1 blsurbn,xregion,cutenur, govhous,pubhous,repstat,srepstat character*2 intmo,intyr real totwt,adjwt integer fullyr real numearn,numauto,vehq,famsize integer membcnt real avar(109),laginc(22) character*1 repflag(109) character*64 ffile(numfiles) !********************************************************************* ! input variables from nipa (see EXTRNIPA.FOR) !********************************************************************* real nipa(109,begyear:1999) !********************************************************************* ! variables created in this program !********************************************************************* integer cexcnt(numfiles) real qpop(numfiles),cexpop(begyear:endyear),q109(109,numfiles),& savetab(2,25,begyear:endyear), mapq(begyear:endyear,numfiles) character*35 savelabl(25) !********************************************************************* ! variable initializations !********************************************************************* data cexcnt/numfiles*0/ data qpop/numfiles*0/ data savelabl/& '1 Cash Income',& '2 Wages and Salaries',& '3 Self-Employment Income',& '4 Capital Income',& '5 Pension Income',& '6 Social Security Income',& '7 Other Government Transfers',& '8 Less Social Insurance Taxes',& '9 Less Federal Income Taxes',& '10 Equals Disposable Income',& '11 Less Cash Expenditures',& '12 Food',& '13 Clothing',& '14 Rent',& '15 Owned Housing Expenses',& '16 Utilities',& '17 Out of Pocket Medical',& '18 Motor Vehicles and Parts',& '19 Furniture and Equipment',& '20 State and Local Taxes',& '21 Other Goods',& '22 Other Services',& '23 Personal Interest Paid',& '24 Equals Saving',& '25 Percent of Disposable Income'/ data ffile /'I:\cexnber\output data files\ffile801',& 'I:\cexnber\output data files\ffile802',& 'I:\cexnber\output data files\ffile803',& 'I:\cexnber\output data files\ffile804',& 'I:\cexnber\output data files\ffile811',& 'I:\cexnber\output data files\ffile812',& 'I:\cexnber\output data files\ffile813',& 'I:\cexnber\output data files\ffile814',& 'I:\cexnber\output data files\ffile821',& 'I:\cexnber\output data files\ffile822',& 'I:\cexnber\output data files\ffile823',& 'I:\cexnber\output data files\ffile824',& 'I:\cexnber\output data files\ffile831',& 'I:\cexnber\output data files\ffile832',& 'I:\cexnber\output data files\ffile833',& 'I:\cexnber\output data files\ffile834',& 'I:\cexnber\output data files\ffile841', & 'I:\cexnber\output data files\ffile842',& 'I:\cexnber\output data files\ffile843',& 'I:\cexnber\output data files\ffile844',& 'I:\cexnber\output data files\ffile851',& 'I:\cexnber\output data files\ffile852',& 'I:\cexnber\output data files\ffile861',& 'I:\cexnber\output data files\ffile862',& 'I:\cexnber\output data files\ffile863',& 'I:\cexnber\output data files\ffile864',& 'I:\cexnber\output data files\ffile871',& 'I:\cexnber\output data files\ffile872',& 'I:\cexnber\output data files\ffile873',& 'I:\cexnber\output data files\ffile874',& 'I:\cexnber\output data files\ffile881',& 'I:\cexnber\output data files\ffile882',& 'I:\cexnber\output data files\ffile883',& 'I:\cexnber\output data files\ffile884',& 'I:\cexnber\output data files\ffile891',& 'I:\cexnber\output data files\ffile892',& 'I:\cexnber\output data files\ffile893',& 'I:\cexnber\output data files\ffile894',& 'I:\cexnber\output data files\ffile901',& 'I:\cexnber\output data files\ffile902',& 'I:\cexnber\output data files\ffile903',& 'I:\cexnber\output data files\ffile904',& 'I:\cexnber\output data files\ffile911',& 'I:\cexnber\output data files\ffile912',& 'I:\cexnber\output data files\ffile913',& 'I:\cexnber\output data files\ffile914',& 'I:\cexnber\output data files\ffile921',& 'I:\cexnber\output data files\ffile922',& 'I:\cexnber\output data files\ffile923',& 'I:\cexnber\output data files\ffile924',& 'I:\cexnber\output data files\ffile931',& 'I:\cexnber\output data files\ffile932',& 'I:\cexnber\output data files\ffile933',& 'I:\cexnber\output data files\ffile934',& 'I:\cexnber\output data files\ffile941',& 'I:\cexnber\output data files\ffile942',& 'I:\cexnber\output data files\ffile943',& 'I:\cexnber\output data files\ffile944',& 'I:\cexnber\output data files\ffile951',& 'I:\cexnber\output data files\ffile952',& 'I:\cexnber\output data files\ffile961',& 'I:\cexnber\output data files\ffile962',& 'I:\cexnber\output data files\ffile963',& 'I:\cexnber\output data files\ffile964',& 'I:\cexnber\output data files\ffile971',& 'I:\cexnber\output data files\ffile972', & 'I:\cexnber\output data files\ffile973',& 'I:\cexnber\output data files\ffile974',& 'I:\cexnber\output data files\ffile981',& 'I:\cexnber\output data files\ffile982',& 'I:\cexnber\output data files\ffile983',& 'I:\cexnber\output data files\ffile984',& 'I:\cexnber\output data files\ffile991',& 'I:\cexnber\output data files\ffile992',& 'I:\cexnber\output data files\ffile993',& 'I:\cexnber\output data files\ffile994',& 'I:\cexnber\output data files\ffile001',& 'I:\cexnber\output data files\ffile002',& 'I:\cexnber\output data files\ffile003',& 'I:\cexnber\output data files\ffile004',& 'I:\cexnber\output data files\ffile011',& 'I:\cexnber\output data files\ffile012'/ !********************************************************************* ! open global files !********************************************************************* open (unit=11,file='I:\cexnber\misc\NIPA\nipa8196.prn',& iostat=ios) open (unit=20,file='I:\cexnber\misc\NIPA\cex nipa comparison.txt') ! INITIALIZE cexpop=0 mapq=0 !********************************************************************* ! read NIPA input array from NIPAEXTR.FOR !********************************************************************* do i=1,109 read(11,'(20f8.2)') (nipa(i,j),j=begyear,1999) end do !********************************************************************* ! set weights to map from quarters to years !********************************************************************* mapq(1981,2)=1./32. mapq(1981,3)=3./32. mapq(1981,4)=5./32. mapq(1981,5)=7./32. mapq(1981,6)=7./32. mapq(1981,7)=5./32. mapq(1981,8)=3./32. mapq(1981,9)=1./32. mapq(1982,6)=1./32. mapq(1982,7)=3./32. mapq(1982,8)=5./32. mapq(1982,9)=7./32. mapq(1982,10)=7./32. mapq(1982,11)=5./32. mapq(1982,12)=3./32. mapq(1982,13)=1./32. mapq(1983,10)=1./32. mapq(1983,11)=3./32. mapq(1983,12)=5./32. mapq(1983,13)=7./32. mapq(1983,14)=7./32. mapq(1983,15)=5./32. mapq(1983,16)=3./32. mapq(1983,17)=1./32. mapq(1984,14)=1./32. mapq(1984,15)=3./32. mapq(1984,16)=5./32. mapq(1984,17)=7./32. mapq(1984,18)=7./32. mapq(1984,19)=5./32. mapq(1984,20)=3./32. mapq(1984,21)=1./32. mapq(1985,18)=1./32. mapq(1985,19)=3./32. mapq(1985,20)=5./32. mapq(1985,21)=7./32. ! use 85:2 as a proxy for 85:3,4 mapq(1985,22)=15./32. mapq(1985,23)=1./32. ! use 85:2 as a proxy for 85:3,4 mapq(1986,22)=9./32. mapq(1986,23)=7./32. mapq(1986,24)=7./32. mapq(1986,25)=5./32. mapq(1986,26)=3./32. mapq(1986,27)=1./32. mapq(1987,24)=1./32. mapq(1987,25)=3./32. mapq(1987,26)=5./32. mapq(1987,27)=7./32. mapq(1987,28)=7./32. mapq(1987,29)=5./32. mapq(1987,30)=3./32. mapq(1987,31)=1./32. mapq(1988,28)=1./32. mapq(1988,29)=3./32. mapq(1988,30)=5./32. mapq(1988,31)=7./32. mapq(1988,32)=7./32. mapq(1988,33)=5./32. mapq(1988,34)=3./32. mapq(1988,35)=1./32. mapq(1989,32)=1./32. mapq(1989,33)=3./32. mapq(1989,34)=5./32. mapq(1989,35)=7./32. mapq(1989,36)=7./32. mapq(1989,37)=5./32. mapq(1989,38)=3./32. mapq(1989,39)=1./32. mapq(1990,36)=1./32. mapq(1990,37)=3./32. mapq(1990,38)=5./32. mapq(1990,39)=7./32. mapq(1990,40)=7./32. mapq(1990,41)=5./32. mapq(1990,42)=3./32. mapq(1990,43)=1./32. mapq(1991,40)=1./32. mapq(1991,41)=3./32. mapq(1991,42)=5./32. mapq(1991,43)=7./32. mapq(1991,44)=7./32. mapq(1991,45)=5./32. mapq(1991,46)=3./32. mapq(1991,47)=1./32. mapq(1992,44)=1./32. mapq(1992,45)=3./32. mapq(1992,46)=5./32. mapq(1992,47)=7./32. mapq(1992,48)=7./32. mapq(1992,49)=5./32. mapq(1992,50)=3./32. mapq(1992,51)=1./32. mapq(1993,48)=1./32. mapq(1993,49)=3./32. mapq(1993,50)=5./32. mapq(1993,51)=7./32. mapq(1993,52)=7./32. mapq(1993,53)=5./32. mapq(1993,54)=3./32. mapq(1993,55)=1./32. mapq(1994,52)=1./32. mapq(1994,53)=3./32. mapq(1994,54)=5./32. mapq(1994,55)=7./32. mapq(1994,56)=7./32. mapq(1994,57)=5./32. mapq(1994,58)=3./32. mapq(1994,59)=1./32. mapq(1995,56)=1./32. mapq(1995,57)=3./32. mapq(1995,58)=5./32. mapq(1995,59)=7./32. ! Use 95 Q2 as a proxy for Q3 and Q4 ! Use 96 Q2 as a proxy for 96 Q1 mapq(1995,60)=15./32. ! mapq(1995,61)=1./32. WAS 96Q1 mapq(1995,62)=1./32. ! use 85:2 as a proxy for 85:3,4 mapq(1996,60)=9./32. ! mapq(1996,61)=7./32. WAS 96Q1 mapq(1996,62)=14./32. mapq(1996,63)=5./32. mapq(1996,64)=3./32. mapq(1996,65)=1./32. mapq(1997,62)=1./32. mapq(1997,63)=3./32. mapq(1997,64)=5./32. mapq(1997,65)=7./32. mapq(1997,66)=7./32. mapq(1997,67)=5./32. mapq(1997,68)=3./32. mapq(1997,69)=1./32. mapq(1998,66)=1./32. mapq(1998,67)=3./32. mapq(1998,68)=5./32. mapq(1998,69)=7./32. mapq(1998,70)=7./32. mapq(1998,71)=5./32. mapq(1998,72)=3./32. mapq(1998,73)=1./32. mapq(1999,70)=1./32. mapq(1999,71)=3./32. mapq(1999,72)=5./32. mapq(1999,73)=7./32. mapq(1999,74)=7./32. mapq(1999,75)=5./32. mapq(1999,76)=3./32. mapq(1999,77)=1./32. mapq(2000,74)=1./32. mapq(2000,75)=3./32. mapq(2000,76)=5./32. mapq(2000,77)=7./32. mapq(2000,78)=7./32. mapq(2000,79)=5./32. mapq(2000,80)=3./32. mapq(2000,81)=1./32. mapq(2001,78)=1./32. mapq(2001,79)=3./32. mapq(2001,80)=5./32. mapq(2001,81)=7./32. mapq(2001,82)=7./32. mapq(2001,83)=5./32. mapq(2001,84)=3./32. mapq(2001,85)=1./32. !********************************************************************* ! read cex data from EXTRFAM.FOR !********************************************************************* ifile=1 40 continue open(unit=10,file=ffile(ifile)) 50 continue read(10,11,end=80)& newid,blsurbn,xregion,cutenur,& govhous,pubhous,repstat,srepstat,& intmo,intyr,totwt,adjwt,& fullyr,numearn,numauto,vehq,& famsize,membcnt,& (avar(i),i=1,109),& (laginc(i),i=1,22), & (repflag(i),i=1,109) 11 format(i7,7a1,2a2,2f11.3,i1,4f4.1,i2,131f10.2,109a1) if (cutenur.eq.'6') goto 50 if (fullyr.ne.1) goto 50 if (repstat.ne.'1') goto 50 cexcnt(ifile)=cexcnt(ifile)+1 ! if (cexcnt(ifile).ge.100) goto 80 xwt=(adjwt/1000) do i=1,109 q109(i,ifile)=q109(i,ifile)+avar(i)*xwt end do qpop(ifile)=qpop(ifile)+xwt goto 50 80 continue PRINT *,"pop =", QPOP(IFILE) close (unit=10) ifile=ifile+1 if (ifile.lt.numfiles) goto 40 !********************************************************************* ! map elements into savetab !********************************************************************* do k=begyear,endyear do j=1,numfiles if (mapq(k,j).ne.0) then cexpop(k)=cexpop(k)+qpop(j)*mapq(k,j) savetab(1,2,k)=savetab(1,2,k)+q109(1,j)*mapq(k,j) savetab(1,3,k)=savetab(1,3,k)+(q109(2,j)+q109(3,j))*mapq(k,j) savetab(1,4,k)=savetab(1,4,k)+(q109(4,j)+q109(5,j)+q109(6,j)) *mapq(k,j) savetab(1,5,k)=savetab(1,5,k)+q109(7,j)*mapq(k,j) savetab(1,6,k)=savetab(1,6,k)+q109(8,j)*mapq(k,j) do i=9,14 savetab(1,7,k)=savetab(1,7,k)+q109(i,j)*mapq(k,j) end do do i=16,17 !16 excludes gov't retirement savetab(1,8,k)=savetab(1,8,k)+q109(i,j)*mapq(k,j) end do savetab(1,9,k)=savetab(1,9,k)+q109(18,j)*mapq(k,j) do i=23,25 savetab(1,12,k)=savetab(1,12,k)+q109(i,j)*mapq(k,j) end do savetab(1,13,k)=savetab(1,13,k)+q109(29,j)*mapq(k,j) savetab(1,14,k)=savetab(1,14,k)+q109(34,j)*mapq(k,j) savetab(1,15,k)=savetab(1,15,k)+(q109(76,j)+q109(77,j)+ q109(78,j))*mapq(k,j) do i=38,42 savetab(1,16,k)=savetab(1,16,k)+q109(i,j)*mapq(k,j) end do do i=44,49 savetab(1,17,k)=savetab(1,17,k)+q109(i,j)*mapq(k,j) end do savetab(1,18,k)=savetab(1,18,k)+(q109(52,j)+q109(53,j)) *mapq(k,j) savetab(1,19,k)=savetab(1,19,k)+q109(36,j)*mapq(k,j) do i=19,22 savetab(1,20,k)=savetab(1,20,k)+q109(i,j)*mapq(k,j) end do savetab(1,21,k)=savetab(1,21,k)+(q109(26,j)+& q109(27,j)+q109(28,j)+q109(31,j)+q109(32,j)+q109(37,j)+& q109(55,j)+q109(61,j)+q109(62,j)+q109(63,j))*mapq(k,j) savetab(1,22,k)=savetab(1,22,k)+(q109(30,j)+& q109(33,j)+q109(35,j)+q109(43,j)+q109(50,j)+q109(51,j)+& q109(54,j)+q109(56,j)+q109(57,j)+q109(58,j)+q109(59,j)+& q109(60,j)+q109(64,j)+q109(65,j)+q109(66,j)+q109(67,j)+& q109(68,j)+q109(69,j))*mapq(k,j) savetab(1,23,k)=savetab(1,23,k)+(q109(71,j)+q109(72,j)) *mapq(k,j) end if end do end do do k=begyear,endyear savetab(2,2,k)=nipa(1,k) savetab(2,3,k)=(nipa(2,k)+nipa(3,k)) savetab(2,4,k)=(nipa(4,k)+nipa(5,k)+nipa(6,k)) savetab(2,5,k)=nipa(7,k) savetab(2,6,k)=nipa(8,k) do i=9,14 savetab(2,7,k)=savetab(2,7,k)+nipa(i,k) end do do i=15,17 savetab(2,8,k)=savetab(2,8,k)+nipa(i,k) end do savetab(2,9,k)=nipa(18,k) do i=23,25 savetab(2,12,k)=savetab(2,12,k)+nipa(i,k) end do savetab(2,13,k)=nipa(29,k) savetab(2,14,k)=nipa(34,k) savetab(2,15,k)=(nipa(76,k)+nipa(77,k)+nipa(78,k)) do i=38,42 savetab(2,16,k)=savetab(2,16,k)+nipa(i,k) end do do i=44,49 savetab(2,17,k)=savetab(2,17,k)+nipa(i,k) end do savetab(2,18,k)=(nipa(52,k)+nipa(53,k)) savetab(2,19,k)=nipa(36,k) do i=19,22 savetab(2,20,k)=savetab(2,20,k)+nipa(i,k) end do savetab(2,21,k)=(nipa(26,k)+& nipa(27,k)+nipa(28,k)+nipa(31,k)+nipa(32,k)+nipa(37,k)+& nipa(55,k)+nipa(61,k)+nipa(62,k)+nipa(63,k)) savetab(2,22,k)=(nipa(30,k)+& nipa(33,k)+nipa(35,k)+nipa(43,k)+nipa(50,k)+nipa(51,k)+& nipa(54,k)+nipa(56,k)+nipa(57,k)+nipa(58,k)+nipa(59,k)+& nipa(60,k)+nipa(64,k)+nipa(65,k)+nipa(66,k)+nipa(67,k)+& nipa(68,k)+nipa(69,k)) savetab(2,23,k)=nipa(71,k)+nipa(72,k) end do !********************************************************************* ! sum savetab elements and write file !********************************************************************* do k=begyear,endyear do i=1,2 do j=2,7 savetab(i,1,k)=savetab(i,1,k)+savetab(i,j,k) end do savetab(i,10,k)=savetab(i,1,k)-savetab(i,8,k)-savetab(i,9,k) do j=12,23 savetab(i,11,k)=savetab(i,11,k)+savetab(i,j,k) end do savetab(i,24,k)=savetab(i,10,k)-savetab(i,11,k) savetab(i,25,k)=100*savetab(i,24,k)/savetab(i,10,k) end do end do write(20,'(''POPULATION'')') write(20,'(25i8)') (i,i=begyear,endyear) write(20,'(25f8.0)') (cexpop(i),i=begyear,endyear) write(20,'(''CEX Aggregates '')') write(20,'('' '')') write(20,'(30x,25i8)') (i,i=begyear,endyear) write(20,'('' '')') do i=1,24 write(20,'(a30,25f8.0)') savelabl(i),(savetab(1,i,k)/1000000,k=begyear,endyear) end do write(20,'(a30,25f8.1)') savelabl(25), (savetab(1,25,k),k=begyear,endyear) write(20,'('' '')') write(20,'(''NIPA Aggregates '')') write(20,'('' '')') write(20,'(30x,25i8)') (i,i=begyear,endyear) write(20,'('' '')') do i=1,24 write(20,'(a30,25f8.0)') savelabl(i), (savetab(2,i,k),k=begyear,endyear) end do write(20,'(a30,25f8.1)') savelabl(25), (savetab(2,25,k),k=begyear,endyear) write(20,'('' '')') write(20,'(''Ratio of CEX to NIPA '')') write(20,'('' '')') write(20,'(30x,25i8)') (i,i=begyear,endyear) write(20,'('' '')') do i=1,24 write(20,'(a30,25f8.1)') savelabl(i),& (.0001*savetab(1,i,k)/savetab(2,i,k),k=begyear,endyear) end do 900 continue end subroutine aggregate_cex