c
c       this program estimates the mileage model.
c
c                        main ->                agederiv,ageeffect,
c                                               cexprep,covar,decompos1,
c                                               decompos2,demogderiv,
c                                               estim,estimalt,
c                                               estimamoeba,gridsrch,
c                                               hsimul,initia,likely,
c                                               momlogit,ols,plotmiles
c main ->                agederiv ->            hconst,heval,parset2,
c                                               share,shareinit,
c                                               shareres,uhatconst1,
c                                               uhatconst2
c main ->                ageeffect ->           linv3f
c uhatconst1 ->          amoeba ->              share
c estimamoeba ->         amoebaout ->           likelypass
c main ->                cexprep ->             kernel
c main,estim, ->         covar ->               eigrs,likobs,linv3f,
c estimamoeba                                   parset1,parset2
c                                               shareinit
c ols ->                 covols ->              linv3f
c initia ->              datget
c main ->                decompos1 ->           hconst,heval,kernel,
c                                               linv3f,parset2,share,
c                                               shareinit,shareres,
c                                               uhatconst1,uhatconst2
c main ->                decompos2 ->           hconst,heval,kernel,
c                                               linv3f,parset2,share,
c                                               shareinit,shareres,
c                                               uhatconst1,uhatconst2
c main ->                demogderiv ->          hconst,heval,parset2,
c                                               share,shareinit,
c                                               shareres,uhatconst1,
c                                               uhatconst2
c covar,waldtest,ols ->  eigrs
c main ->                estim ->               covar,likely,opt
c main ->                estimalt ->            likely
c main ->                estimamoeba ->         amoebaout,covar,
c                                               likelypass
c main ->                gridsrch ->            likely
c agederiv, ->           hconst ->              heval
c decompos1,decompos2,
c demogderiv,likobs
c agederiv,decompos1, -> heval ->               interp
c decompos2,demogderiv,
c hconst,hsimul,
c plotmiles
c main ->                hsimul ->              heval,mdnris,parset1,
c                                               parset2,rand2,
c                                               shareinit,sharep,utrunc
c main ->                initia ->              datget,parget
c heval ->               interp
c cexprep,decompos1, ->  kernel
c decompos2
c likobs ->              lanormd
c main,estim,estimalt -> likely ->              likobs,parset1,parset2,
c gridsrch,likelypass,                          shareinit
c nmsimp
c amoebaout, ->          likelypass ->          likely
c estimamoeba
c covar,likely ->        likobs ->              hconst,lanormd,
c                                               share,sharenorm,
c                                               uhatconst1,uhatconst2
c ageeffect,covar, ->    linv3f ->              ludatn,luelmn
c covols,decompos1,
c decompos2,logitcovar,
c ols,uhatconst2,
c waldtest
c momlogit ->            logitcovar ->          linv3f,parset1,parset2
c momlogit ->            logitmom ->            parset1,parset2
c linv3f ->              ludatn
c linv3f ->              luelmn
c hsimul,plotmiles ->    mdnris ->              merfi
c mdnris ->              merfi
c main ->                momlogit ->            logitcovar,logitmom,opt
c opt ->                 nmsimp ->              likely
c main ->                ols ->                 covols,eigrs,waldtest,
c                                               linv3f
c estim,momlogit ->      opt ->                 nmsimp
c initia ->              parget
c covar,hsimul, ->       parset1
c likely,logitcovar,
c logitmom,plotmiles
c agederiv,covar, ->     parset2
c decompos1,decompos2,
c demogderiv,hsimul,
c likely,logitcovar,
c logitmom,plotmiles
c plotmiles ->           plotdprep
c main ->                plotmiles ->           heval,mdnris,parset1,
c                                               parset2,plotdprep,rand2,
c                                               shareinit,sharep,utrunc
c hsimul,plotmiles ->    rand2
c agederiv,amoeba, ->    share
c decompos1,decompos2,
c demogderiv,likobs,
c stairs,uhatconst1
c agederiv,covar, ->     shareinit
c decompos1,decompos2,
c demogderiv,hsimul,
c likely,plotmiles
c likobs ->              sharenorm
c hsimul,plotmiles ->    sharep
c agederiv,decompos1, -> shareres
c decompos2,demogderiv,
c uhatconst1,uhatconst2
c uhatconst1 ->          stairs ->              share
c agederiv, ->           uhatconst1 ->          amoeba,shareres,stairs
c decompos1,decompos2,
c demogderiv,likobs
c agederiv, ->           uhatconst2 ->          linv3f,shareres 
c decompos1,decompos2,
c demogderiv,likobs
c hsimul,plotmiles ->    utrunc
c ols ->                 waldtest ->            eigrs,linv3f
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=ncars-1,
     & ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      dimension parm(ncoefs)
      call initia(method,parm,nparm)
      if(method.eq.0)call likely(parm,nparm,f,ier)
      if(method.eq.1)call estim(parm,nparm)
      if(method.eq.2)call estimalt(parm,nparm)
      if(method.eq.3)call estimamoeba(parm,nparm)
      if(method.eq.4)call covar(parm)
      if(method.eq.5)call ols
      if(method.eq.6)call momlogit
      if(method.eq.7)call gridsrch
      if(method.eq.8)call ageeffect
      if(method.eq.9)call agederiv
      if(method.eq.10)call demogderiv
      if(method.eq.11)call decompos1
      if(method.eq.12)call decompos2
      if(method.eq.13)call cexprep
      if(method.eq.14)call plotmiles(parm)
      if(method.eq.15)call hsimul(parm)
   2  continue
      stop
      end
c
c
      subroutine agederiv
c
c       this subroutine computes the distribution of age derivatives 
c       disaggregated by brand and age.
c
      parameter(nobss=26000,nobsss=nobss*2,nhouses=11,nccharts=2,
     & ncars=10,ncarm1s=ncars-1,ncchars=80,npolys=2,nbrs=23,nbr3s=
     & nbrs+3,nages=13)
      implicit real*8(a-h,o-z)
      character*8 abrand(nbr3s),awhich(2)
      real hchar,propmil,summiles
      dimension basemiles(ncars,2),deriv(nbr3s,nages,2,5),derivsum(5),
     & dmiles(2),dresid(ncars,ncars),iaggv(nbr3s),prop(ncars),
     & resid(ncars),uhat(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data awhich/'car','othr car'/
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
c
c       initialize.
c
      call parset2
      imshr=2
      nbrand=26
      nage=10
      do 8 i=1,nbrand
         do 8 j=1,nage
            do 8 k=1,2
               do 9 l=1,3
   9              deriv(i,j,k,l)=0.d0
               deriv(i,j,k,4)=1.d20
   8           deriv(i,j,k,5)=-1.d20
c
c       compute derivatives for each observation.
c
      do 2 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
 100     format(1x,'i = ',i6)
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 3 j=1,ncart
   3           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute mileage for each car.
c       compute household characteristics term.
c
         prdsm=0.d0
         do 4 j=1,nhouse
   4        prdsm=prdsm+(gamma(j)*dble(hchar(i,j)))
c
c       compute total miles for household.
c
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
         call heval(ncart,prdsm,uhatl,h,1)
         basesum=exp(log(dble(summiles(i)))-h)
         if(ncart.le.1)then
            basemiles(1,1)=basesum
            basemiles(1,2)=0.d0   
            endif
         if(ncart.gt.1)then
c
c       compute proportions and mileage for each car.
c
            do 5 j=1,ncart
               jj=index(i)+j
               prop(j)=dble(propmil(jj))-resid(j)
               basemiles(j,1)=basesum*prop(j)
   5           basemiles(j,2)=basesum*(1.d0-prop(j))
            endif
c
c       compute derivatives.
c
         do 6 j=1,ncart
            ij=index(i)+j
            iage=icchar(ij,2)+1
            if(iage.gt.10)iage=10
            icchar(ij,2)=icchar(ij,2)+1
            call shareinit
c
c       compute mileage for each car.
c
            call shareres(uhat,ncartm1,resid,dresid,0)
            call heval(ncart,prdsm,uhatl,h,1)
            dsum=exp(log(dble(summiles(i)))-h)
            if(ncart.le.1)then
               dmiles(1)=(dsum-basemiles(1,1))/basemiles(1,1)
               dmiles(2)=0.d0
               endif
            if(ncart.gt.1)then
               jj=index(i)+j
               dpropj=dble(propmil(jj))-resid(j)
               dmiles(1)=((dsum*dpropj)-basemiles(j,1))/basemiles(j,1)
               dmiles(2)=((dsum*(1.d0-dpropj))-basemiles(j,2))/
     &          basemiles(j,2)
               endif
c
c       update derivative moments.
c
            ibrand=iaggv(icchar(ij,1))
            do 13 k=1,2
               if((k.eq.1).or.(ncart.gt.1))then
                  deriv(ibrand,iage,k,1)=deriv(ibrand,iage,k,1)+1.d0
                  deriv(ibrand,iage,k,2)=deriv(ibrand,iage,k,2)+
     &             dmiles(k)
                  deriv(ibrand,iage,k,3)=deriv(ibrand,iage,k,3)+
     &             (dmiles(k)*dmiles(k))
                  if(deriv(ibrand,iage,k,4).gt.dmiles(k))
     &             deriv(ibrand,iage,k,4)=dmiles(k)
                  if(deriv(ibrand,iage,k,5).lt.dmiles(k))
     &             deriv(ibrand,iage,k,5)=dmiles(k)
                  endif
  13           continue
   6        icchar(ij,2)=icchar(ij,2)-1
   2     continue
c
c       adjust moments and output.
c
      do 14 i=1,2
         write(6,110)
 110     format(1x,50('='))
         write(6,102)awhich(i)
 102     format(1x,'moments of derivatives for ',a8,/,1x,'brand',5x,
     &    'age',7x,'# obs',3x,'mean',6x,'std dev',3x,'minimum',3x,
     &    'maximum')
         do 10 j=1,nbrand
            do 12 k=1,3
  12           derivsum(k)=0.d0
            derivsum(4)=1.d20
            derivsum(5)=-1.d20
            iflag=0
            do 11 k=1,nage
               if(deriv(j,k,i,1).gt.0.)then
                  do 15 l=1,3
  15                 derivsum(l)=derivsum(l)+deriv(j,k,i,l)
                  if(derivsum(4).gt.deriv(j,k,i,4))derivsum(4)=
     &             deriv(j,k,i,4)
                  if(derivsum(5).lt.deriv(j,k,i,5))derivsum(5)=
     &             deriv(j,k,i,5)
                  if(deriv(j,k,i,1).le.3)then
                     if(iflag.eq.0)then
                        write(6,101)abrand(j)
                        iflag=1
                        endif
                     write(6,104)k,deriv(j,k,i,1)
 104                 format(11x,i2,3x,f6.1)
                     endif
                  if(deriv(j,k,i,1).gt.3)then
                     deriv(j,k,i,2)=deriv(j,k,i,2)/deriv(j,k,i,1)
                     deriv(j,k,i,3)=((deriv(j,k,i,3)/deriv(j,k,i,1))-
     &                (deriv(j,k,i,2)*deriv(j,k,i,2)))**.5d0
                     if(iflag.eq.0)then
                        write(6,101)abrand(j)
 101                    format(1x,a8)
                        iflag=1
                        endif
                     write(6,103)k,(deriv(j,k,i,l),l=1,5)
 103                 format(11x,i2,8x,f6.1,4(2x,f8.4))
                     endif
                  endif
  11           continue
            if(derivsum(1).le.3.)write(6,106)abrand(j),derivsum(1)
 106        format(1x,a8,2x,'average',1x,f8.1)
            if(derivsum(1).gt.3.)then
               derivsum(2)=derivsum(2)/derivsum(1)
               derivsum(3)=((derivsum(3)/derivsum(1))-(derivsum(2)*
     &          derivsum(2)))**.5d0
               write(6,105)(derivsum(k),k=1,5)
 105           format(11x,'average',1x,f8.1,4(2x,f8.4))
               endif
  10        continue
  14     continue
      return
      end
c
c
      subroutine ageeffect
c
c       this subroutine estimates the average age effect on average 
c       mileage disaggregated by number of household cars.
c
      parameter(nobss=26000,nobsss=nobss*2,nhouses=11,ncars=10,
     & nccharts=2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension beta(6),work1(6),work2(12),xdt(ncars),xdtt(ncars),
     & xt(2),xx(2,2),xxd(ncars,ncars),xy(2),xyd(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
c
c       initialize.
c
      itwo=2
      xt(1)=1.d0
      xdt(1)=1.d0
      do 2 i=1,5
c
c       initialize for each car portfolio size.
c
         write(6,100)i
 100     format(1x,'results for households with ',i1,' cars')
         do 6 j=1,2
            xy(j)=0.d0
            do 6 k=1,2
   6           xx(j,k)=0.d0
         do 10 j=1,6
            xyd(j)=0.d0
            do 10 k=1,6
  10           xxd(j,k)=0.d0
         nobst=0
         ip1=i+1
         ip1c=ip1
         if(ip1c.gt.4)ip1c=4
         do 3 j=1,nobs
c
c       check if the j'th household has the correct number of cars.
c
            ncart=ncar(j)
            if(((i.lt.5).and.(ncart.eq.i)).or.((i.eq.5).and.
     &       (ncart.ge.i)))then
c
c       update relevant moment matrices.
c
               nobst=nobst+1
               xt(2)=0.d0
               do 4 k=1,ncart
                  kj=index(j)+k
                  kp1=k+1
                  xdtt(kp1)=dble(float(icchar(kj,2)))
   4              xt(2)=xt(2)+xdtt(kp1)
               do 13 k=2,ip1c
               xmin=1.d20
                  do 14 l=2,ip1
                     if(xmin.gt.xdtt(l))then
                        xmin=xdtt(l)
                        kco=l
                        endif
  14                 continue
                  xdt(k)=xmin
  13              xdtt(kco)=1.d20
               yt=log(dble(summiles(j))/ncart)
               xt(2)=xt(2)/ncart
               do 5 k=1,2
                  xy(k)=xy(k)+(yt*xt(k))
                  do 5 l=1,2
   5                 xx(k,l)=xx(k,l)+(xt(k)*xt(l))
               do 9 k=1,ip1c
                  xyd(k)=xyd(k)+(yt*xdt(k))
                  do 9 l=1,ip1c
   9                 xxd(k,l)=xxd(k,l)+(xdt(k)*xdt(l))
               endif
   3        continue
c
c       finish for average effects.
c       invert.
c
         d1=-1.d0
         call linv3f(xx,work1,1,itwo,2,d1,d2,work2,ier)
         if(ier.ne.0)then
            write(6,101)ier
 101        format(1x,'inversion problem: ier = ',i3)
            goto 2
            endif
c
c       multiply.
c
         do 7 j=1,2
            beta(j)=0.d0
            do 8 k=1,2
   8           beta(j)=beta(j)+(xx(j,k)*xy(k))
   7        continue
c
c       output.
c
         write(6,102)nobst,(beta(j),j=1,2)
 102     format(1x,'nobs = ',i5,/,1x,'beta =',5(2x,g15.8))
c
c       finish for disaggregated effects.
c       invert.
c
         d1=-1.d0
         call linv3f(xxd,work1,1,ip1c,ncars,d1,d2,work2,ier)
         if(ier.ne.0)then
            write(6,101)ier
            goto 2
            endif
c
c       multiply.
c
         do 11 j=1,ip1c
            beta(j)=0.d0
            do 12 k=1,ip1c
  12           beta(j)=beta(j)+(xxd(j,k)*xyd(k))
  11        continue
c
c       output.
c
         write(6,102)nobst,(beta(j),j=1,ip1c)
   2     continue
      return
      end
c
c
      subroutine amoeba(p,y,ndim,ftol,funk,iter,ibest,ytol)
c
c       this is the numerical recipes simplex program (page 292).
c
      parameter(ncars=10,ncarm1s=ncars-1)
      implicit real*8(a-h,o-z)
      dimension p(ncars,ncarm1s),y(ncars),pr(ncarm1s),prr(ncarm1s),
     & pbar(ncarm1s)
      common/yiter/itmax
      external funk
      itmax=100
      mpts=ndim+1
      alpha=1.d0
      alpha1=1.d0+alpha
      gamma=2.d0
      gamma1=1.d0-gamma
      beta=.5d0
      beta1=1.d0-beta
      iter=0
   1  ilo=1
      if(y(1).gt.y(2))then
         ihi=1
         inhi=2
      else
         ihi=2
         inhi=1
         endif
      do 11 i=1,mpts
         if(y(i).lt.y(ilo))ilo=i
         if(y(i).gt.y(ihi))then
            inhi=ihi
            ihi=i
         else if(y(i).gt.y(inhi))then
            if(i.ne.ihi)inhi=i
            endif
  11     continue
      rtol=2.d0*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
      if(rtol.lt.ftol)then
         ibest=ilo
         return
         endif
      if(iter.eq.itmax)then
         ibest=ilo
         return
         endif
      iter=iter+1
      do 12 j=1,ndim
  12     pbar(j)=0.d0
      do 14 i=1,mpts
         if(i.ne.ihi)then
            do 13 j=1,ndim
  13           pbar(j)=pbar(j)+p(i,j)
            endif
  14     continue
      do 15 j=1,ndim
         pbar(j)=pbar(j)/ndim
  15     pr(j)=(alpha1*pbar(j))-(alpha*p(ihi,j))
      call funk(pr,ndim,ypr)
      if(ypr.lt.ytol)then
         do 30 j=1,ndim
  30        p(1,j)=pr(j)
         y(1)=ypr
         ibest=1
         return
         endif
      if(ypr.le.y(ilo))then
         do 16 j=1,ndim
  16        prr(j)=(gamma*pr(j))+(gamma1*pbar(j))
         call funk(prr,ndim,yprr)
         if(yprr.lt.ytol)then
            do 31 j=1,ndim
  31           p(1,j)=prr(j)
            y(1)=yprr
            ibest=1
            return
            endif
         if(yprr.lt.y(ilo))then
            do 17 j=1,ndim
  17           p(ihi,j)=prr(j)
            y(ihi)=yprr
         else
            do 18 j=1,ndim
  18           p(ihi,j)=pr(j)
            y(ihi)=ypr
            endif
      else if(ypr.ge.y(inhi))then
         if(ypr.lt.y(ihi))then
            do 19 j=1,ndim
  19           p(ihi,j)=pr(j)
            y(ihi)=ypr
            endif
         do 21 j=1,ndim
  21        prr(j)=(beta*p(ihi,j))+(beta1*pbar(j))
         call funk(prr,ndim,yprr)
         if(yprr.lt.ytol)then
            do 32 j=1,ndim
  32           p(1,j)=prr(j)
            y(1)=yprr
            ibest=1
            return
            endif
         if(yprr.lt.y(ihi))then
            do 22 j=1,ndim
  22           p(ihi,j)=prr(j)
            y(ihi)=yprr
         else
            do 24 i=1,mpts
               if(i.ne.ilo)then
                  do 23 j=1,ndim
                     pr(j)=0.5d0*(p(i,j)+p(ilo,j))
  23                 p(i,j)=pr(j)
                  call funk(pr,ndim,yt)
                  if(yt.lt.ytol)then
                     do 33 j=1,ndim
  33                    p(1,j)=prr(j)
                     y(1)=yt
                     ibest=1
                     return
                     endif
                  y(i)=yt
                  endif
  24           continue
            endif
      else
         do 25 j=1,ndim
  25        p(ihi,j)=pr(j)
         y(ihi)=ypr
         endif
      goto 1
      end
c
c
      subroutine amoebaout(p,y,ndim,ftol,funk,iter,ibest,ytol)
c
c       this is the numerical recipes simplex program (page 292).
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s,ncoef1s=
     & ncoefs+1)
      implicit real*8(a-h,o-z)
      dimension p(ncoef1s,ncoefs),y(ncoef1s),pr(ncoefs),prr(ncoefs),
     & pbar(ncoefs)
      external funk
      itmaxout=1000
      mpts=ndim+1
      alpha=1.d0
      alpha1=1.d0+alpha
      gamma=2.d0
      gamma1=1.d0-gamma
      beta=.5d0
      beta1=1.d0-beta
      iter=0
      write(6,101)y(1),(p(1,j),j=1,ndim)
 101  format(1x,'start of amoeba:',/,1x,'initial value of obj: ',g15.8,
     & /,1x,'initial value of parm: ',3(1x,g15.8),50(/,23x,
     & 3(1x,g15.8)))
   1  ilo=1
      if(y(1).gt.y(2))then
         ihi=1
         inhi=2
      else
         ihi=2
         inhi=1
         endif
      do 11 i=1,mpts
         if(y(i).lt.y(ilo))ilo=i
         if(y(i).gt.y(ihi))then
            inhi=ihi
            ihi=i
         else if(y(i).gt.y(inhi))then
            if(i.ne.ihi)inhi=i
            endif
  11     continue
      rtol=2.d0*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
      if(rtol.lt.ftol)then
         ibest=ilo
         return
         endif
      if(iter.eq.itmaxout)then
         ibest=ilo
         return
         endif
      iter=iter+1
      if(((iter/10)*10).eq.iter)write(6,100)iter,y(ilo),(p(ilo,j),
     & j=1,ndim)
 100  format(1x,i5,2x,'y = ',g15.8,2x,'x =',3(1x,g15.8),50(/,27x,
     & 3(1x,g15.8)))
      do 12 j=1,ndim
  12     pbar(j)=0.d0
      do 14 i=1,mpts
         if(i.ne.ihi)then
            do 13 j=1,ndim
  13           pbar(j)=pbar(j)+p(i,j)
            endif
  14     continue
      do 15 j=1,ndim
         pbar(j)=pbar(j)/ndim
  15     pr(j)=(alpha1*pbar(j))-(alpha*p(ihi,j))
      call funk(pr,ndim,ypr)
      if(ypr.lt.ytol)then
         do 30 j=1,ndim
  30        p(1,j)=pr(j)
         y(1)=ypr
         ibest=1
         return
         endif
      if(ypr.le.y(ilo))then
         do 16 j=1,ndim
  16        prr(j)=(gamma*pr(j))+(gamma1*pbar(j))
         call funk(prr,ndim,yprr)
         if(yprr.lt.ytol)then
            do 31 j=1,ndim
  31           p(1,j)=prr(j)
            y(1)=yprr
            ibest=1
            return
            endif
         if(yprr.lt.y(ilo))then
            do 17 j=1,ndim
  17           p(ihi,j)=prr(j)
            y(ihi)=yprr
         else
            do 18 j=1,ndim
  18           p(ihi,j)=pr(j)
            y(ihi)=ypr
            endif
      else if(ypr.ge.y(inhi))then
         if(ypr.lt.y(ihi))then
            do 19 j=1,ndim
  19           p(ihi,j)=pr(j)
            y(ihi)=ypr
            endif
         do 21 j=1,ndim
  21        prr(j)=(beta*p(ihi,j))+(beta1*pbar(j))
         call funk(prr,ndim,yprr)
         if(yprr.lt.ytol)then
            do 32 j=1,ndim
  32           p(1,j)=prr(j)
            y(1)=yprr
            ibest=1
            return
            endif
         if(yprr.lt.y(ihi))then
            do 22 j=1,ndim
  22           p(ihi,j)=prr(j)
            y(ihi)=yprr
         else
            do 24 i=1,mpts
               if(i.ne.ilo)then
                  do 23 j=1,ndim
                     pr(j)=0.5d0*(p(i,j)+p(ilo,j))
  23                 p(i,j)=pr(j)
                  call funk(pr,ndim,yt)
                  if(yt.lt.ytol)then
                     do 33 j=1,ndim
  33                    p(1,j)=prr(j)
                     y(1)=yt
                     ibest=1
                     return
                     endif
                  y(i)=yt
                  endif
  24           continue
            endif
      else
         do 25 j=1,ndim
  25        p(ihi,j)=pr(j)
         y(ihi)=ypr
         endif
      goto 1
      end
c
c
      subroutine cexprep
c
c       this subroutine prepares data for the cex study to compute 
c       average cost per mile.
c
      parameter(nbrs=23,nbr3s=nbrs+3,ncars=10,nccharts=2,nhouses=11,
     & nincs=5,nobss=26000,nobsss=nobss*2,nvmiles=13)
      implicit real*8(a-h,o-z)
      character*8 abrand(nbr3s)
      real hchar,propmil,summiles
      dimension aimom(2),akern(nincs),amiles(ncars),glinc(nincs),
     & iaggv(nbr3s),vmiles(nincs,2,4,nbr3s,nvmiles,4,5),weight1(5),
     & weight2(4)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
      data weight1/.1,.2,.4,.2,.1/
      data weight2/.5,.3,.15,.05/
c
c       initialize.
c
      ninc=5
      nbr=26
      nvmile=13
      do 7 i=1,ninc
         do 7 j=1,2
            do 7 k=1,4
               do 7 l=1,nbr
                  do 7 m=1,nvmile
                     do 7 n=1,4
                        do 8 ii=1,3
   8                       vmiles(i,j,k,l,m,n,ii)=0.d0
                        vmiles(i,j,k,l,m,n,4)=1.d20
   7                    vmiles(i,j,k,l,m,n,5)=-1.d20
c
c       find moments of log income distribution.
c
      aimom(1)=0.d0
      aimom(2)=0.d0
      do 5 i=1,nobs
         alinc=hchar(i,2)
         aimom(1)=aimom(1)+alinc
   5     aimom(2)=aimom(2)+(alinc*alinc)
      aimom(1)=aimom(1)/nobs
      aimom(2)=((aimom(2)/nobs)-(aimom(1)*aimom(1)))**.5d0
      glinc(1)=aimom(1)-(2.d0*aimom(2))
      write(6,103)(aimom(i),i=1,2)
 103  format(1x,'log income moments:',/,1x,'mean: ',g15.8,/,1x,
     & 'std dev.: ',g15.8,//,1x,'income groups',/,1x,'group',2x,
     & 'log income value')
      write(6,104)1,glinc(1)
 104  format(1x,i1,6x,g15.8)
      do 6 i=2,ninc
         glinc(i)=glinc(i-1)+aimom(2)
   6     write(6,104)i,glinc(i)
      bandi=aimom(2)/2.d0
      write(6,105)
 105  format(1x,50('='))
c
c       process each observation.
c
      do 2 i=1,nobs
         alinc=hchar(i,2)
         iurb=hchar(i,3)+1.01
         ndrv=hchar(i,6)+1.01
         if(ndrv.gt.4)ndrv=4
         ncart=ncar(i)
         ncart4=ncart
         if(ncart4.gt.4)ncart4=4
         do 9 j=1,ninc
            glinct=glinc(j)
            call kernel(alinc,glinct,bandi,akernt)
   9        akern(j)=akernt
         do 3 j=1,ncart
            ij=index(i)+j
            ia=icchar(ij,2)
            iab=ia-2
            if(iab.lt.1)iab=1
            iae=ia+2
            if(iae.gt.nvmile)iae=nvmile
            iap3=ia+3
            amiles(j)=summiles(i)*propmil(ij)
            ibr=iaggv(icchar(ij,1))
            do 4 k=1,ninc
               if(akern(k).gt.0.)then
                  do 11 l=iab,iae
                     akernt=akern(k)*weight1(iap3-l)
                     do 12 m=1,4
                        mn=m-ncart4
                        if(mn.lt.0)mn=-1*mn
                        mn=mn+1
                        akerntt=akernt*weight2(mn)
                        vmiles(k,iurb,ndrv,ibr,l,m,1)=
     &                   vmiles(k,iurb,ndrv,ibr,l,m,1)+akerntt
                        vmiles(k,iurb,ndrv,ibr,l,m,2)=
     &                   vmiles(k,iurb,ndrv,ibr,l,m,2)+(akerntt*
     &                   amiles(j))
                        vmiles(k,iurb,ndrv,ibr,l,m,3)=
     &                   vmiles(k,iurb,ndrv,ibr,l,m,3)+(akerntt*
     &                   amiles(j)*amiles(j))
                        if(vmiles(k,iurb,ndrv,ibr,l,m,4).gt.amiles(j))
     &                   vmiles(k,iurb,ndrv,ibr,l,m,4)=amiles(j)
                        if(vmiles(k,iurb,ndrv,ibr,l,m,5).lt.amiles(j))
     &                   vmiles(k,iurb,ndrv,ibr,l,m,5)=amiles(j)
  12                    continue
  11                 continue
                  endif
   4           continue
   3        continue
   2     continue
c
c       adjust moments and output.
c
      write(6,100)
 100  format(1x,'disaggregated miles moments',/,1x,'inc group',2x,
     & 'urban',2x,'# drvrs',2x,'brand #',2x,'brand',5x,'age',2x,
     & '# cars',2x,'weight',5x,'mean',6x,'std dev',3x,'minimum',3x,
     & 'maximum')
      open(unit=8,file='disagmiles.d')
      do 10 i=1,ninc
         do 10 j=1,2
            jm1=j-1
            do 10 k=1,4
               do 10 l=1,nbr
                  do 10 m=1,nvmile
                     do 10 n=1,4
                        if(vmiles(i,j,k,l,m,n,1).le.0.)then
                           write(6,101)i,jm1,k,l,abrand(l),m,n,
     &                      vmiles(i,j,k,l,m,n,1)
 101                       format(1x,i2,9x,i1,6x,i1,8x,i2,7x,a8,2x,i2,
     &                      3x,i1,7x,f8.3)
                           write(8,110)i,jm1,k,l,abrand(l),m,n,
     &                      (vmiles(i,j,k,l,m,n,ii),ii=1,3)
 110                       format(1x,i2,2(1x,i1),1x,i2,1x,a8,1x,i2,1x,
     &                      i1,1x,3(1x,f8.3))
                           endif
                        if(vmiles(i,j,k,l,m,n,1).gt.0.)then
                           vmiles(i,j,k,l,m,n,2)=vmiles(i,j,k,l,m,n,2)/
     &                      vmiles(i,j,k,l,m,n,1)
                           vmiles(i,j,k,l,m,n,3)=
     &                      (vmiles(i,j,k,l,m,n,3)/
     &                      vmiles(i,j,k,l,m,n,1))-
     &                      (vmiles(i,j,k,l,m,n,2)*
     &                      vmiles(i,j,k,l,m,n,2))
                           if(vmiles(i,j,k,l,m,n,3).gt.0.)
     &                      vmiles(i,j,k,l,m,n,3)=vmiles(i,j,k,l,m,n,3)
     &                      **.5d0
                           if(vmiles(i,j,k,l,m,n,3).le.0.)
     &                      vmiles(i,j,k,l,m,n,3)=0.d0
                           write(6,102)i,jm1,k,l,abrand(l),m,n,
     &                      (vmiles(i,j,k,l,m,n,ii),ii=1,5)
 102                       format(1x,i2,9x,i1,6x,i1,8x,i2,7x,a8,2x,i2,
     &                      3x,i1,5x,5(2x,f8.3))
                           write(8,110)i,jm1,k,l,abrand(l),m,n,
     &                      (vmiles(i,j,k,l,m,n,ii),ii=1,3)
                           endif
  10                    continue
      close(8)
      return
      end
c
c
      subroutine covar(parm)
c
c       this subroutine computes the covariance matrix of the 
c       estimates.
c
      parameter(ncchars=80,nccharts=2,npolys=2,nhouses=11,ncars=10,
     & ncarm1s=ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s,
     & ncoef2s=ncoefs*2,ncoefss=(ncoefs+1)*ncoefs/2,nobss=26000,
     & nobsss=nobss*2)
      implicit real*8(a-h,o-z)
      character*2 star(3),start
      character*3 amxmn(2),amxmnt
      character*8 alabel
      real hchar,propmil,summiles
      dimension amean(ncoefs),cov(ncoefs,ncoefs),cove1(ncoefss),
     & cove2(ncoefs,ncoefs),cove3(ncoefss),dft(ncoefs),eigval(ncoefs),
     & eigvec(ncoefs,ncoefs),icomxmn(ncoefs,2),parm(ncoefs),
     & work1(ncoefs),work2(ncoef2s)
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      data amxmn/'min','max'/
      data star/'  ','* ','**'/
c
c       initialize.
c
      ilev=2
      niterd=4
      call parset1(parm)
      do 5 i=1,ncoef
         amean(i)=0.d0
         icomxmn(i,1)=0
         icomxmn(i,2)=0
         do 5 j=1,i
   5        cov(i,j)=0.d0
c
c       update with each observation.
c
      do 3 i=1,nobs
         if(((i/10)*10).eq.i)write(6,102)i
 102     format(1x,'i = ',i6)
c
c       compute log likelihood contribution at estimate.
c
         iobs=i
         call parset2
         call shareinit
         call likobs(i,ft0)
c
c       deviate each parameter and compute numerical derivative.
c
         iparm=0
         do 2 j=1,ncoef
            if(icoef(j).eq.0)then
               iparm=iparm+1
               iterd=0
               delta=abs(coef(j))/1.d2
               if(delta.lt..01)delta=.01d0
               if(delta.gt.1.)delta=1.d0
  11           coef(j)=coef(j)+delta
               call parset2
               call shareinit
               call likobs(i,ft1)
               if(ilev.eq.2)then
                  coef(j)=coef(j)-(2.d0*delta)
                  call parset2
                  call shareinit
                  call likobs(i,ft2)
                  if(((ft1-ft0)*(ft0-ft2)).ge.0.)then
                     dft(iparm)=(ft1-ft2)/(2.d0*delta)
                     coef(j)=coef(j)+delta
                     endif
                  if(((ft1-ft0)*(ft0-ft2)).lt.0.)then
                     coef(j)=coef(j)+delta
                     iterd=iterd+1
                     if(iterd.lt.niterd)then
                        delta=delta/2.d0
                        goto 11
                        endif
                     if(iterd.eq.niterd)then
c                       dft(iparm)=(ft1-ft2)/(2.d0*delta)
                        dft(iparm)=0.d0
                        if(ft1.gt.ft0)then
                           icomxmn(j,1)=icomxmn(j,1)+1
                           amxmnt=amxmn(1)
                           endif
                        if(ft1.lt.ft0)then
                           icomxmn(j,2)=icomxmn(j,2)+1
                           amxmnt=amxmn(2)
                           endif
c                       write(6,109)amxmnt,i,j,ft0,ft2,ft1,delta
 109                    format(1x,a3,' for obs ',i5,', parm ',i3,':',/,
     &                   1x,' ft0 = ',g15.8,' ft0-delta = ',g15.8,
     &                   ' ft0+delta = ',g15.8,' delta = ',g15.8)
                        endif
                     endif
                  endif
               if(ilev.eq.1)then
                  dft(iparm)=(ft1-ft0)/delta
                  coef(j)=coef(j)-delta
                  endif
               endif
   2        continue
c
c       update mean and outer product.
c
         do 4 j=1,iparm
            amean(j)=amean(j)+dft(j)
            do 4 k=1,j
   4           cov(j,k)=cov(j,k)+(dft(j)*dft(k))
   3     continue
c
c       adjust moments.
c
      anobs=dble(float(nobs))
      do 6 i=1,iparm
   6     amean(i)=amean(i)/anobs
      ij=0
      do 7 i=1,iparm
         do 7 j=1,i
            cov(i,j)=(cov(i,j)/anobs)-(amean(i)*amean(j))
            cov(j,i)=cov(i,j)
            ij=ij+1
            cove2(i,j)=cov(i,j)
   7        cove1(ij)=cov(i,j)
c
c       output average log likelihood contribution derivatives.
c
      snobs=anobs**.5d0
      write(6,101)
 101  format(1x,50('-'))
      write(6,103)
 103  format(1x,'moments for average log likelihood contribution',/,1x,
     & 'derivatives',/,1x,'variable',2x,'mean derivative',2x,
     & 't-statistic',2x,'# obs at min',2x,'# obs at max')
      iparm=0
      do 8 i=1,ncoef
         if(icoef(i).eq.0)then
            iparm=iparm+1
            tstat=snobs*amean(iparm)/(cov(iparm,iparm)**.5d0)
            atstat=abs(tstat)
            if(atstat.lt.1.54)start=star(1)
            if((atstat.ge.1.54).and.(atstat.lt.1.96))start=star(2)
            if(atstat.ge.1.96)start=star(3)
            write(6,100)alabel(iparm),amean(iparm),start,tstat,
     &       (icomxmn(i,j),j=1,2)
 100        format(1x,a8,2x,f8.4,a2,7x,f8.2,5x,i5,7x,i5)
            endif
   8     continue
c
c       invert covariance matrix.
c
      d1=-1.d0
      call linv3f(cov,work1,1,iparm,ncoefs,d1,d2,work2,ier)
      if(ier.ne.0)then
         write(6,104)ier
 104     format(1x,'ier on inversion = ',i3)
         ij=0
         do 12 i=1,iparm
            do 12 j=1,i
               ij=ij+1
  12           cove3(ij)=cove2(i,j)/((cove2(i,i)*cove2(j,j))**.5d0)
         call eigrs(cove1,iparm,1,eigval,eigvec,ncoefs,work1,ier)
         write(6,110)
 110     format(1x,'eigenvalues and eigenvectors without',
     &    ' normalization')
         do 13 i=1,iparm
            if(eigval(i).gt..1d-4)goto 14
  13        write(6,111)i,eigval(i),(eigvec(j,i),j=1,iparm)
 111     format(1x,i3,2x,g15.8,3x,4(2x,g15.8),10(/,24x,4(2x,g15.8)))
  14     continue
         call eigrs(cove3,iparm,1,eigval,eigvec,ncoefs,work1,ier)
         write(6,112)
 112     format(1x,'eigenvalues and eigenvectors with normalization')
         do 15 i=1,iparm
            if(eigval(i).gt..1d-4)goto 16
  15        write(6,111)i,eigval(i),(eigvec(j,i),j=1,iparm)
  16     continue
         stop
         endif
c
c       output covariance matrix.
c
      write(6,101)
      write(6,106)
 106  format(1x,'asymptotic covariance matrix',/,1x,'var #',2x,
     & 'variable',2x,'covariance terms')
      do 9 i=1,iparm
   9     write(6,105)i,alabel(i),(cov(i,j),j=1,i)
 105  format(1x,i3,4x,a8,4(2x,g15.8),50(/,16x,4(2x,g15.8)))
c
c       output statistical info for each variable.
c
      write(6,101)
      write(6,108)
 108  format(1x,'statistical properties of estimates',/,1x,'variable',
     & 2x,'estimate',4x,'std err',3x,'t-stat')
      iparm=0
      do 10 i=1,ncoef
         if(icoef(i).eq.0)then
            iparm=iparm+1
            stderr=cov(iparm,iparm)**.5d0/snobs
            tstat=coef(i)/stderr
            atstat=abs(tstat)
            if(atstat.lt.1.54)start=star(1)
            if((atstat.ge.1.54).and.(atstat.lt.1.96))start=star(2)
            if(atstat.ge.1.96)start=star(3)
            write(6,107)alabel(iparm),coef(i),start,stderr,tstat
 107        format(1x,a8,2x,f8.4,a2,2x,f8.4,2x,f8.2)
            endif
  10     continue
      return
      end
c
c
      subroutine covols(icase,bhat,cov,sig)
c
c       this subroutine computes the covariance matrix for the ols 
c       estimates taking into account the correlation caused by having 
c       multiple vehicles from the same household.
c
      parameter(ncars=10,ncarp1s=ncars+1,nccharts=2,nhouses=11,
     & nobss=26000,nobsss=nobss*2,nbrs=23,nbr3s=nbrs+3,nx1s=nbrs+3,
     & nx3s=nx1s+nhouses,nx4s=nx3s+(2*nbrs)-1,nx42s=nx4s*2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension aresid2(ncars,3),avresid(2),bhat(nx4s),cov(nx4s,nx4s),
     & itrnsl(nbr3s),nxc(4),sig(2),sig2(2),w(ncarp1s,2),weight(ncarp1s),
     & work1(nx4s),work2(nx42s),ww(2,2),wz(2),x(nx4s),xh(ncars,nx4s),
     & xox(nx4s,nx4s),xx(nx4s,nx4s),z(ncarp1s)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      data itrnsl/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     & 21,22,0,0,23/
c
c       initialize.
c
      nbr=23
      nx1=nbr+3
      nx1m1=nx1-1
      nx2=nx1+(2*nbr)-1
      nx3=nx1+nhouse
      nx4=nx3+(2*nbr)-1
      nxc(1)=nx1
      nxc(2)=nx2
      nxc(3)=nx3
      nxc(4)=nx4
      nx=nxc(icase)
      nresid=0
      resid2=0.d0
      do 10 i=1,ncars
         do 10 j=1,3
  10        aresid2(i,j)=0.d0
c
c       compute sum of squared residuals and sum of mean squared 
c       residuals.
c
      do 2 i=1,nobs
         ncart=ncar(i)
         aresid=0.d0
         do 3 j=1,ncart
c
c       construct car characteristics vector.
c
            ij=index(i)+j
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            x(1)=1.d0
            x(2)=age/10.d0
            if((icase.eq.1).or.(icase.eq.3))then
               x(3)=agetr/10.d0
               kad=3
               endif
            if((icase.eq.2).or.(icase.eq.4))kad=2
            do 4 k=1,nbr
               k3=k+kad
   4           x(k3)=0.d0
            itrnt=itrnsl(icchar(ij,1))
            if(itrnt.gt.0)x(itrnt+kad)=1.d0
            if((icase.eq.2).or.(icase.eq.4))then
               do 5 k=nx1,nx2
   5              x(k)=0.d0
               if(itrnt.gt.0)then
                  x(nx1m1+itrnt)=age/10.d0
                  x(nx1m1+nbr+itrnt)=agetr/10.d0
                  endif 
               if(icase.eq.4)then
                  x(nx2+1)=dble(float(ncar(i)))
                  do 7 k=2,nhouse
   7                 x(nx2+k)=dble(hchar(i,k))
                  endif
               endif
            if(icase.eq.3)then
               x(nx1+1)=dble(float(ncar(i)))
               do 6 k=2,nhouse
   6              x(nx1+k)=dble(hchar(i,k))
               endif
c
c      construct residuals.
c
            resid=log(dble(summiles(i)*propmil(ij)))
            do 8 k=1,nx
   8           resid=resid-(bhat(k)*x(k))
            resid2=resid2+(resid*resid)
   3        aresid=aresid+resid
         aresid=aresid/dble(float(ncart))
         aresid2(ncart,1)=aresid2(ncart,1)+1.d0
         aresid2(ncart,2)=aresid2(ncart,2)+aresid
         aresid2(ncart,3)=aresid2(ncart,3)+(aresid*aresid)
   2     nresid=nresid+ncart
      resid2=resid2/nresid
      avresid(1)=0.d0
      avresid(2)=0.d0
      do 35 i=1,ncars
         ai=dble(float(i))
         avresid(1)=avresid(1)+(aresid2(i,1)*ai)
  35     avresid(2)=avresid(2)+(aresid2(i,2)*ai)
      avresid(2)=avresid(2)/avresid(1)
      write(6,100)avresid(2)
 100  format(1x,'avg residual = ',g15.8)
      do 9 i=1,ncars
         if(aresid2(i,1).ge.1.)aresid2(i,3)=aresid2(i,3)/aresid2(i,1)
   9     continue
c
c       run a regression to estimate idiosyncratic and household 
c       component.
c
      z(1)=resid2
      w(1,1)=1.d0
      w(1,2)=1.d0
      weight(1)=dble(float(nresid))
      it=1
      do 11 i=1,ncars
         if(aresid2(i,1).ge.1.)then
            it=it+1
            z(it)=aresid2(i,3)
            w(it,1)=1.d0
            w(it,2)=1.d0/dble(float(i))
            weight(it)=aresid2(i,1)
            endif
  11     continue
      do 34 i=1,2
         wz(i)=0.d0
         do 34 j=1,2
  34        ww(i,j)=0.d0
      do 12 i=1,it
         do 12 j=1,2
            wz(j)=wz(j)+(weight(i)*w(i,j)*z(i))
            do 12 k=1,2
  12           ww(j,k)=ww(j,k)+(weight(i)*w(i,j)*w(i,k))
      d1=-1.d0
      call linv3f(ww,work1,1,2,2,d1,d2,work2,ier)
      do 13 i=1,2
         sig2(i)=0.d0
         do 43 j=1,2
  43        sig2(i)=sig2(i)+(ww(i,j)*wz(j))
  13     sig(i)=sig2(i)**.5d0
c
c       compute middle term of covariance matrix.
c
      do 16 i=1,nx
         do 16 j=1,nx
            xx(i,j)=0.d0
  16        xox(i,j)=0.d0
      do 22 i=1,nobs
         ncart=ncar(i)
         do 23 j=1,ncart
c
c       construct car characteristics vector.
c
            ij=index(i)+j
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            xh(j,1)=1.d0
            xh(j,2)=age/10.d0
            if((icase.eq.1).or.(icase.eq.3))then
               xh(j,3)=agetr/10.d0
               kad=3
               endif
            if((icase.eq.2).or.(icase.eq.4))kad=2
            do 24 k=1,nbr
               k3=k+kad
  24           xh(j,k3)=0.d0
            itrnt=itrnsl(icchar(ij,1))
            if(itrnt.gt.0)xh(j,(itrnt+kad))=1.d0
            if((icase.eq.2).or.(icase.eq.4))then
               do 25 k=nx1,nx2
  25              xh(j,k)=0.d0
               if(itrnt.gt.0)then
                  xh(j,(nx1m1+itrnt))=age/10.d0
                  xh(j,(nx1m1+nbr+itrnt))=agetr/10.d0
                  endif 
               if(icase.eq.4)then
                  xh(j,(nx2+1))=dble(float(ncar(i)))
                  do 27 k=2,nhouse
  27                 xh(j,(nx2+k))=dble(hchar(i,k))
                  endif
               endif
            if(icase.eq.3)then
               xh(j,(nx1+1))=dble(float(ncar(i)))
               do 26 k=2,nhouse
  26              xh(j,(nx1+k))=dble(hchar(i,k))
               endif
  23        continue
c
c      compute x'omega x and x'x.  
c
         do 14 j=1,ncart
            do 14 k=1,ncart
               if(j.eq.k)then
                  sigt=sig2(1)+sig2(2)
                  do 19 l=1,nx
                     do 19 m=1,nx
  19                    xx(l,m)=xx(l,m)+(xh(j,l)*xh(j,m))
                  endif
               if(j.ne.k)sigt=sig2(1)
               do 15 l=1,nx
                  do 15 m=1,nx
  15                 xox(l,m)=xox(l,m)+(xh(j,l)*sigt*xh(k,m))
  14           continue
  22     continue
c
c       multiply.
c
      d1=-1.d0
      call linv3f(xx,work1,1,nx,nx4s,d1,d2,work2,ier)
      do 17 i=1,nx
         do 17 j=1,nx
            cov(i,j)=0.d0
            do 18 k=1,nx
               do 18 l=1,nx
  18              cov(i,j)=cov(i,j)+(xx(i,k)*xox(k,l)*xx(j,l))
  17        continue
      return
      end
c
c
      subroutine datget
c
c       this subroutine gets data.
c
      parameter(nobss=26000,nobsss=nobss*2,ncars=10,ncarm1s=ncars-1,
     & ncchars=80,nccharts=2,nccharp2s=ncchars+2,nhouses=11,nhousep2s=
     & nhouses+2,npolys=2,nmisss=5)
      implicit real*8(a-h,o-z)
      character*8 aclabel(ncchars),ahlabel(nhouses),alcar(2),
     & amiss(nmisss),avcar(2)
      real age,agetr,cchart(ncchars),hchar,propmil,summiles,
     & vmiles(ncars)
      dimension cmom(nccharp2s,5),hmom(nhousep2s,5),ihchar(4),
     & imiss(2,nmisss),mveh(6)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data aclabel/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck','age','age5tr','isuzua','isuzub','chryslra',
     & 'chryslrb','dodgea','dodgeb','plymotha','plymothb','forda',
     & 'fordb','mercurya','mercuryb','buicka','buickb','chevrlta',
     & 'chevrltb','oldsmbla','oldsmblb','pontiaca','pontiacb',
     & 'saturna','saturnb','luxamera','luxamerb','luxjpana','luxjpanb',
     & 'luxeurpa','luxeurpb','hondaa','hondab','mitsubia','mitsubib',
     & 'mazdaa','mazdab','nissana','nissanb','subarua','subarub',
     & 'toyotaa','toyotab','volkswga','volkswgb','volvoa','volvob',
     & 'geoa','geob','hyundaia','hyundaib','othera','otherb','trucka',
     & 'truckb'/
      data ahlabel/'constant','lincome','urban','drvrs','drvrst',
     & 'adrvrs','adrvrst','mdrvrs','mdrvrst','wdrvrs','wdrvrst'/
      data alcar/'# cars','miles'/
      data amiss/'model','income','miles','vh age y','vh age o'/
      data avcar/'miles','proport'/
c
c       initialize.
c
      open(unit=8,file='npts.d')
      iobs=0
      nhousep1=nhouse+1
      nhousep2=nhouse+2
      do 11 i=1,nhousep2
         do 12 j=1,3
  12        hmom(i,j)=0.d0
         hmom(i,4)=1.d20
  11     hmom(i,5)=-1.d20
      nccharp1=ncchar+1
      nccharp2=ncchar+2
      do 15 i=1,nccharp2
         do 16 j=1,3
  16        cmom(i,j)=0.d0
         cmom(i,4)=1.d20
  15     cmom(i,5)=-1.d20
      nmiss=5
      do 20 i=1,2
         do 20 j=1,nmiss
  20        imiss(i,j)=0
c
c       read each record.
c
      do 2 i=1,nobs
         ifmiss=0
         if(((i/5000)*5000).eq.i)write(6,120)i,iobs
 120     format(1x,'i = ',i6,' iobs = ',i6)
c
c       read and process household information.
c
         read(8,100,end=3)ihouseid,weight,ihousinc,ibusavl,ipbtravel,
     &    iurban1,iurban2,nhchar,ihco,ihcar
 100     format(1x,i8,1x,f8.2,1x,i5,4(1x,i2),3(1x,i2))
         iobs=iobs+1
         hchar(iobs,1)=1.
         if(ihousinc.le.0)then
            imiss(1,2)=imiss(1,2)+1
            if(ifmiss.eq.0)imiss(2,2)=imiss(2,2)+1
            ifmiss=1
            endif
         if(ihousinc.gt.0)hchar(iobs,2)=log(float(ihousinc))
         hchar(iobs,3)=float(iurban1)
         hchar(iobs,4)=0.
         hchar(iobs,6)=0.
         hchar(iobs,8)=0.
         hchar(iobs,10)=0.
c
c       read and process household member information.
c
         do 4 j=1,nhchar
            read(8,101)jt,(ihchar(k),k=1,4)
 101        format(2(1x,i2),3(1x,i1))
            if(ihchar(2).eq.1)then
               hchar(iobs,4)=hchar(iobs,4)+1.
               if(ihchar(1).ge.25)hchar(iobs,6)=hchar(iobs,6)+1.
               if(ihchar(3).eq.1)hchar(iobs,8)=hchar(iobs,8)+1.
               if(ihchar(4).eq.1)hchar(iobs,10)=hchar(iobs,10)+1.
               endif
   4        continue
         jt=3
         do 5 j=1,4
            jt=jt+2
            hchar(iobs,jt)=hchar(iobs,(jt-1))
            if(hchar(iobs,jt).gt.2.)hchar(iobs,jt)=2.
   5        continue
c
c       read and process vehicle information.
c
         summiles(iobs)=0.
         ncar(iobs)=ihco
         if(iobs.eq.1)index(iobs)=0
         if(iobs.gt.1)index(iobs)=index(iobs-1)+ncar(iobs-1)
         do 6 j=1,ihco
            read(8,102)(mveh(k),k=1,6)
 102        format(1x,i6,1x,i2,3(1x,i4),1x,i6)
            indexj=index(iobs)+j
            do 7 k=1,nmodel
   7           cchart(k)=0.
            if(mveh(2).eq.0)then
               imiss(1,1)=imiss(1,1)+1
               if(ifmiss.eq.0)imiss(2,1)=imiss(2,1)+1
               ifmiss=1
               endif
            if(ifmiss.eq.0)then
               cchart(mveh(2))=1.
               icchar(indexj,1)=mveh(2)
               iage=1996-mveh(3)
               if(iage.gt.40)then
                  imiss(1,5)=imiss(1,5)+1
                  if(ifmiss.eq.0)imiss(2,5)=imiss(2,5)+1
                  ifmiss=1
                  endif
               if(iage.lt.0)then
                  imiss(1,4)=imiss(1,4)+1
                  if(ifmiss.eq.0)imiss(2,4)=imiss(2,4)+1
                  ifmiss=1
                  endif
               age=float(iage)
               agetr=age
               if(agetr.gt.5.)agetr=5.
               kt=nmodel+1
               cchart(kt)=age
               icchar(indexj,2)=iage
               kt=kt+1
               cchart(kt)=agetr
               ktt=kt
               do 8 k=1,nmodel
                  do 8 l=1,2
                     ktt=ktt+1
   8                 cchart(ktt)=0.
               ktm=kt+((mveh(2)-1)*2)+1
               cchart(ktm)=age
               cchart(ktm+1)=agetr
               endif
            if(mveh(1).gt.1000)then
               imiss(1,3)=imiss(1,3)+1
               if(ifmiss.eq.0)imiss(2,3)=imiss(2,3)+1
               ifmiss=1
               mveh(1)=1000
               endif
            vmiles(j)=float(mveh(1))
   6        summiles(iobs)=summiles(iobs)+float(mveh(1))
         do 9 j=1,ihco
            ij=index(iobs)+j
   9        propmil(ij)=vmiles(j)/summiles(iobs)
         if(ifmiss.eq.1)then
            iobs=iobs-1
            endif
         if(ifmiss.eq.0)then
            do 13 j=1,nhouse
               hmom(j,1)=hmom(j,1)+1.d0
               ahchar=dble(hchar(iobs,j))
               hmom(j,2)=hmom(j,2)+ahchar
               hmom(j,3)=hmom(j,3)+(ahchar*ahchar)
               if(hmom(j,4).gt.ahchar)hmom(j,4)=ahchar
               if(hmom(j,5).lt.ahchar)hmom(j,5)=ahchar
  13           continue
            ancar=dble(float(ncar(iobs)))
            hmom(nhousep1,1)=hmom(nhousep1,1)+1.d0
            hmom(nhousep1,2)=hmom(nhousep1,2)+ancar
            hmom(nhousep1,3)=hmom(nhousep1,3)+(ancar*ancar)
            if(hmom(nhousep1,4).gt.ancar)hmom(nhousep1,4)=ancar
            if(hmom(nhousep1,5).lt.ancar)hmom(nhousep1,5)=ancar
            sumt=dble(summiles(iobs))
            hmom(nhousep2,1)=hmom(nhousep2,1)+1.d0
            hmom(nhousep2,2)=hmom(nhousep2,2)+sumt 
            hmom(nhousep2,3)=hmom(nhousep2,3)+(sumt*sumt)
            if(hmom(nhousep2,4).gt.sumt)hmom(nhousep2,4)=sumt
            if(hmom(nhousep2,5).lt.sumt)hmom(nhousep2,5)=sumt
            do 17 j=1,ihco
               ij=index(iobs)+j
               do 18 k=1,ncchar
                  cmom(k,1)=cmom(k,1)+1.d0
                  acchar=dble(cchart(k))
                  cmom(k,2)=cmom(k,2)+acchar
                  cmom(k,3)=cmom(k,3)+(acchar*acchar)
                  if(cmom(k,4).gt.acchar)cmom(k,4)=acchar
                  if(cmom(k,5).lt.acchar)cmom(k,5)=acchar
  18              continue
               cmom(nccharp1,1)=cmom(nccharp1,1)+1.d0
               avmi=dble(vmiles(j))
               cmom(nccharp1,2)=cmom(nccharp1,2)+avmi
               cmom(nccharp1,3)=cmom(nccharp1,3)+(avmi*avmi)
               if(cmom(nccharp1,4).gt.avmi)cmom(nccharp1,4)=avmi
               if(cmom(nccharp1,5).lt.avmi)cmom(nccharp1,5)=avmi
               cmom(nccharp2,1)=cmom(nccharp2,1)+1.d0
               apropm=dble(propmil(ij))
               cmom(nccharp2,2)=cmom(nccharp2,2)+apropm
               cmom(nccharp2,3)=cmom(nccharp2,3)+(apropm*apropm)
               if(cmom(nccharp2,4).gt.apropm)cmom(nccharp2,4)=apropm
               if(cmom(nccharp2,5).lt.apropm)cmom(nccharp2,5)=apropm
  17           continue
            endif
   2     continue
   3  close(8)
      nobs=iobs
c
c       adjust and output household characteristic moments.
c
      write(6,112)
 112  format(1x,'missing value analysis',/,1x,'reason',4x,'# missing',
     & 2x,'binding')
      do 50 i=1,nmiss
  50     write(6,113)amiss(i),(imiss(j,i),j=1,2)
 113  format(1x,a8,2x,i6,4x,i6)
      write(6,111)nobs
 111  format(1x,'# observations: ',i8)
      write(6,105)
 105  format(1x,50('-'))
      write(6,106)
 106  format(1x,'moments of household characteristics',/,1x,'variable',
     & 2x,'# obs',5x,'mean',6x,'std dev',3x,'minimum',3x,'maximum') 
      do 10 i=1,nhouse
         hmom(i,2)=hmom(i,2)/hmom(i,1)
         hmom(i,3)=((hmom(i,3)/hmom(i,1))-(hmom(i,2)*hmom(i,2)))**.5d0
  10     write(6,104)ahlabel(i),(hmom(i,j),j=1,5)
 104  format(1x,a8,2x,f8.1,4(2x,f8.3))
      hmom(nhousep1,2)=hmom(nhousep1,2)/hmom(nhousep1,1)
      hmom(nhousep1,3)=((hmom(nhousep1,3)/hmom(nhousep1,1))-
     & (hmom(nhousep1,2)*hmom(nhousep1,2)))**.5d0
      write(6,104)alcar(1),(hmom(nhousep1,i),i=1,5)
      hmom(nhousep2,2)=hmom(nhousep2,2)/hmom(nhousep2,1)
      hmom(nhousep2,3)=((hmom(nhousep2,3)/hmom(nhousep2,1))-
     & (hmom(nhousep2,2)*hmom(nhousep2,2)))**.5d0
      write(6,104)alcar(2),(hmom(nhousep2,i),i=1,5)
c
c       adjust and output vehicle moments.
c
      write(6,105)
      write(6,108)
 108  format(1x,'moments of vehicle characteristics',/,1x,'variable',
     & 2x,'# obs',5x,'mean',6x,'std dev',3x,'minimum',3x,'maximum')
      do 14 i=1,ncchar
         cmom(i,2)=cmom(i,2)/cmom(i,1)
         cmom(i,3)=((cmom(i,3)/cmom(i,1))-(cmom(i,2)*cmom(i,2)))**.5d0
  14     write(6,107)aclabel(i),(cmom(i,j),j=1,5)
 107  format(1x,a8,2x,f8.1,4(2x,f8.3))
      cmom(nccharp1,2)=cmom(nccharp1,2)/cmom(nccharp1,1)
      cmom(nccharp1,3)=((cmom(nccharp1,3)/cmom(nccharp1,1))-
     & (cmom(nccharp1,2)*cmom(nccharp1,2)))**.5d0
      write(6,107)avcar(1),(cmom(nccharp1,i),i=1,5)
      cmom(nccharp2,2)=cmom(nccharp2,2)/cmom(nccharp2,1)
      cmom(nccharp2,3)=((cmom(nccharp2,3)/cmom(nccharp2,1))-
     & (cmom(nccharp2,2)*cmom(nccharp2,2)))**.5d0
      write(6,107)avcar(2),(cmom(nccharp2,i),i=1,5)
      return
      end
c
c
      subroutine decompos1
c
c       this subroutine decomposes average derivatives of log mileage 
c       with respect to age into an age effect, a portfolio effect, and
c       a household demographics effect.  then it runs ols regressions 
c       of the effects on age effects on prices and on ols age effects 
c       on mileage.
c
      parameter(nobss=26000,nobsss=nobss*2,nhouses=11,nccharts=2,
     & ncars=10,ncarm1s=ncars-1,ncchars=80,npolys=2,nbrs=23,nbr3s=
     & nbrs+3,nages=13)
      implicit real*8(a-h,o-z)
      character*2 star(3),start
      character*8 abrand(nbr3s),ameth(3),avar(2)
      real hchar,propmil,summiles
      dimension amilesl(nbr3s),amilesv(nobsss),b(2,2),basemiles(ncars),
     & deriv(3,nbr3s,nages,5),derivsum(3,nbr3s,5),denom(3),dmiles(3),
     & dresid(ncars,ncars),iaggv(nbr3s),prdsmmom(5),prdsmv(nobss),
     & pricesl(nbr3s),prop(ncars),resid(ncars),uhat(ncars),work1(2),
     & work2(4),xx(2,2),xxv(2,2,2),xy(2,2)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data ameth/'age','total','no demog'/
      data avar/'constant','slope'/
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
      data star/'  ','* ','**'/
c
c       initialize.
c
      call parset2
      imshr=2
      nbrand=26
      nage=10
      do 8 i=1,3
         do 8 j=1,nbrand
            do 8 k=1,nage
               do 9 l=1,3
   9              deriv(i,j,k,l)=0.d0
               deriv(i,j,k,4)=1.d20
   8           deriv(i,j,k,5)=-1.d20
c
c       compute bandwidth for kernel function.
c
      do 18 i=1,3
  18     prdsmmom(i)=0.d0
      prdsmmom(4)=1.d20
      prdsmmom(5)=-1.d20
      do 26 i=1,nobs
         prdsm=0.d0
         do 27 j=1,nhouse
  27        prdsm=prdsm+(gamma(j)*dble(hchar(i,j)))
         prdsmmom(1)=prdsmmom(1)+1.d0
         prdsmmom(2)=prdsmmom(2)+prdsm
         prdsmmom(3)=prdsmmom(3)+(prdsm*prdsm)
         if(prdsmmom(4).gt.prdsm)prdsmmom(4)=prdsm
         if(prdsmmom(5).lt.prdsm)prdsmmom(5)=prdsm
         prdsmv(i)=prdsm
  26     continue
      prdsmmom(2)=prdsmmom(2)/prdsmmom(1)
      prdsmmom(3)=((prdsmmom(3)/prdsmmom(1))-(prdsmmom(2)*prdsmmom(2)))
     & **.5d0
      bandconst=.25d0
      bandprd=prdsmmom(3)*bandconst
      write(6,113)(prdsmmom(i),i=2,5),bandprd
 113  format(1x,'moments for prdsm:',/,1x,'mean: ',g15.8,/,1x,
     & 'std dev: ',g15.8,/,1x,'minimum: ',g15.8,/,1x,'maximum: ',g15.8,
     & /,1x,'bandwidth for kernel: ',g15.8)
c
c       prepare for total derivative calculation.
c
      write(6,110)
      write(6,112)
 112  format(1x,'preparation')
      do 19 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
 100     format(1x,'i = ',i6)
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 13 j=1,ncart
  13           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute total miles for household.
c
         prdsm=prdsmv(i)
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
         call heval(ncart,prdsm,uhatl,h,1)
         basesum=exp(log(dble(summiles(i)))-h)
         if(ncart.le.1)then
            jj=index(i)+1
            amilesv(jj)=basesum
            endif
         if(ncart.gt.1)then
c
c       compute proportions and mileage for each car.
c
            do 33 j=1,ncart
               jj=index(i)+j
               prop(j)=dble(propmil(jj))-resid(j)
  33           amilesv(jj)=basesum*prop(j)
            endif
  19     continue
c
c       compute derivatives for each observation.
c
      do 2 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 3 j=1,ncart
   3           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute mileage for each car.
c       compute total miles for household.
c
         prdsm=prdsmv(i)
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
c
c       compute proportions and mileage for each car.
c
         do 5 j=1,ncart
            jj=index(i)+j
   5        basemiles(j)=amilesv(jj)
c
c       compute derivatives.
c
         do 6 j=1,ncart
            ij=index(i)+j
            iage=icchar(ij,2)+1
            if(iage.gt.10)iage=10
            icchar(ij,2)=icchar(ij,2)+1
            call shareinit
c
c       compute mileage for each car.
c
            call shareres(uhat,ncartm1,resid,dresid,0)
            call heval(ncart,prdsm,uhatl,h,1)
            dsum=exp(log(dble(summiles(i)))-h)
            if(ncart.le.1)dmiles(1)=(dsum-basemiles(1))/basemiles(1)
            if(ncart.gt.1)then
               jj=index(i)+j
               dpropj=dble(propmil(jj))-resid(j)
               dmiles(1)=((dsum*dpropj)-basemiles(j))/basemiles(j)
               endif
c
c       compute total effect (including household demographic effects 
c       and portfolio effects) and compute total effect minus portfolio
c       effect.
c
            ibrand=iaggv(icchar(ij,1))
            do 20 k=2,3
               dmiles(k)=0.d0
  20           denom(k)=0.d0
            do 16 k=1,nobs
               if(k.eq.i)goto 16
               ncartc=ncar(k)
c
c       measure distance between household and candidate other 
c       household.
c       check for match on brand and age.
c
               do 17 l=1,ncartc
                  kl=index(k)+l
                  lbrand=iaggv(icchar(kl,1))
                  if(lbrand.eq.ibrand)then
                     iagec=icchar(kl,2)
                     if(iagec.gt.10)iagec=10
                     if(iagec.eq.iage)then
c
c       match on brand.  check for household demographic match.
c
                        prdsmc=prdsmv(k)
                        call kernel(prdsm,prdsmc,bandprd,akern)
                        dmt=(amilesv(kl)-basemiles(j))/basemiles(j)
                        if(dmt.gt..5)dmt=.5d0
                        if(dmt.lt.-.5)dmt=-.5d0
                        dmiles(2)=dmiles(2)+dmt
                        dmiles(3)=dmiles(3)+(akern*dmt)
                        denom(2)=denom(2)+1.d0 
                        denom(3)=denom(3)+akern
                        endif
                     endif
  17              continue
  16           continue
c
c       update derivative moments.
c
            deriv(1,ibrand,iage,1)=deriv(1,ibrand,iage,1)+1.d0
            deriv(1,ibrand,iage,2)=deriv(1,ibrand,iage,2)+dmiles(1)
            deriv(1,ibrand,iage,3)=deriv(1,ibrand,iage,3)+(dmiles(1)*
     &       dmiles(1))      
            if(deriv(1,ibrand,iage,4).gt.dmiles(1))
     &       deriv(1,ibrand,iage,4)=dmiles(1)      
            if(deriv(1,ibrand,iage,5).lt.dmiles(1))
     &       deriv(1,ibrand,iage,5)=dmiles(1)
            do 21 k=2,3
               if(denom(k).gt.0.)then
                  dmiles(k)=dmiles(k)/denom(k)
                  deriv(k,ibrand,iage,1)=deriv(k,ibrand,iage,1)+1.d0
                  deriv(k,ibrand,iage,2)=deriv(k,ibrand,iage,2)+
     &             dmiles(k)
                  deriv(k,ibrand,iage,3)=deriv(k,ibrand,iage,3)+
     &             (dmiles(k)*dmiles(k))
                  if(deriv(k,ibrand,iage,4).gt.dmiles(k))
     &             deriv(k,ibrand,iage,4)=dmiles(k)
                  if(deriv(k,ibrand,iage,5).lt.dmiles(k))
     &             deriv(k,ibrand,iage,5)=dmiles(k)
                  endif
  21           continue
   6        icchar(ij,2)=icchar(ij,2)-1
   2     continue
c
c       adjust moments and output.
c
      do 10 i=1,nbrand
         write(6,110)
 110     format(1x,50('='))
         write(6,110)
         write(6,102)abrand(i)
 102     format(1x,'moments of derivatives for ',a8)
         do 14 j=1,3
            write(6,110)
            write(6,107)ameth(j)
 107        format(1x,'using method: ',a8)
            do 12 k=1,3
  12           derivsum(j,i,k)=0.d0
            derivsum(j,i,4)=1.d20
            derivsum(j,i,5)=-1.d20
            write(6,101)
 101        format(1x,'age',5x,'# obs',5x,'mean',6x,'std dev',3x,
     &       'minimum',3x,'maximum')
            do 11 k=1,nage
               if(deriv(j,i,k,1).le.0.)then
                  do 24 l=2,5
  24                 deriv(j,i,k,l)=-99.d0
                  endif
               if(deriv(j,i,k,1).gt.0.)then
                  do 15 l=1,3
  15                 derivsum(j,i,l)=derivsum(j,i,l)+deriv(j,i,k,l)
                  if(derivsum(j,i,4).gt.deriv(j,i,k,4))derivsum(j,i,4)=
     &             deriv(j,i,k,4)
                  if(derivsum(j,i,5).lt.deriv(j,i,k,5))derivsum(j,i,5)=
     &             deriv(j,i,k,5)
                  if(deriv(j,i,k,1).le.3)then
                     write(6,104)k,deriv(j,i,k,1)
 104                 format(1x,i2,6x,f8.1)
                     do 23 l=2,5
  23                    deriv(j,i,k,l)=-99.d0
                     endif
                  if(deriv(j,i,k,1).gt.3)then
                     deriv(j,i,k,2)=deriv(j,i,k,2)/deriv(j,i,k,1)
                     deriv(j,i,k,3)=((deriv(j,i,k,3)/deriv(j,i,k,1))-
     &                (deriv(j,i,k,2)*deriv(j,i,k,2)))**.5d0
                     write(6,103)k,(deriv(j,i,k,l),l=1,5)
 103                 format(1x,i2,6x,f8.1,4(2x,f8.4))
                     endif
                  endif
  11           continue
            if(derivsum(j,i,1).le.3.)then
               write(6,106)derivsum(j,i,1)
 106           format(1x,'average',1x,f8.1)
               do 25 k=2,5
  25              derivsum(j,i,k)=-99.d0
               endif
            if(derivsum(j,i,1).gt.3.)then
               derivsum(j,i,2)=derivsum(j,i,2)/derivsum(j,i,1)
               derivsum(j,i,3)=((derivsum(j,i,3)/derivsum(j,i,1))-
     &          (derivsum(j,i,2)*derivsum(j,i,2)))**.5d0
               write(6,105)(derivsum(j,i,k),k=1,5)
 105           format(1x,'average',1x,f8.1,4(2x,f8.4))
               endif
  14        continue
         write(6,110)
         write(6,108)(ameth(j),j=1,3)
 108     format(1x,'comparison of means across decompositions',/,1x,
     &    'age',4x,3(2x,a8))
         do 22 j=1,nage
            if((deriv(1,i,j,2).gt.-90.).and.(deriv(2,i,j,2).gt.-90.)
     &       .and.(deriv(3,i,j,2).gt.-90.))write(6,109)j,
     &       (deriv(k,i,j,2),k=1,3)
 109        format(1x,i2,7x,3(2x,f8.4))
            if((deriv(1,i,j,2).gt.-90.).and.(deriv(2,i,j,2).gt.-90.)
     &       .and.(deriv(3,i,j,2).le.-90.))write(6,119)j,
     &       (deriv(k,i,j,2),k=1,2)
 119        format(1x,i2,7x,2(2x,f8.4))
            if((deriv(1,i,j,2).gt.-90.).and.(deriv(2,i,j,2).le.-90.)
     &       .and.(deriv(3,i,j,2).gt.-90.))write(6,120)j,
     &       deriv(1,i,j,2),deriv(3,i,j,2)
 120        format(1x,i2,7x,2x,f8.4,12x,f8.4)
            if((deriv(1,i,j,2).gt.-90.).and.(deriv(2,i,j,2).le.-90.)
     &       .and.(deriv(3,i,j,2).le.-90.))write(6,121)j,deriv(1,i,j,2)
 121        format(1x,i2,9x,f8.4)
            if((deriv(1,i,j,2).le.-90.).and.(deriv(2,i,j,2).gt.-90.)
     &       .and.(deriv(3,i,j,2).gt.-90.))write(6,122)j,
     &       (deriv(k,i,j,2),k=2,3)
 122        format(1x,i2,17x,2(2x,f8.4))
            if((deriv(1,i,j,2).le.-90.).and.(deriv(2,i,j,2).gt.-90.)
     &       .and.(deriv(3,i,j,2).le.-90.))write(6,123)j,deriv(2,i,j,2)
 123        format(1x,i2,19x,f8.4)
            if((deriv(1,i,j,2).le.-90.).and.(deriv(2,i,j,2).le.-90.)
     &       .and.(deriv(3,i,j,2).gt.-90.))write(6,124)j,deriv(3,i,j,2)
 124        format(1x,i2,29x,f8.4)
            if((deriv(1,i,j,2).le.-90.).and.(deriv(2,i,j,2).le.-90.)
     &       .and.(deriv(3,i,j,2).le.-90.))write(6,125)j
 125        format(1x,i2)
  22        continue
         write(6,111)(derivsum(j,i,2),j=1,3)
 111     format(1x,'average',3(2x,f8.4))
  10     continue
c
c       run regressions on averages.
c
      write(6,110)
      open(unit=8,file='olsdata.prn')
      do 40 i=1,nbrand
  40     read(8,126)amilesl(i),pricesl(i)
 126  format(16x,f8.4,8x,f8.3)
      close(8)
      n2=2
      do 30 i=1,3
         do 29 j=1,2
            do 29 k=1,2
               xy(j,k)=0.d0
               do 29 l=1,2
  29              xxv(j,k,l)=0.d0
         do 28 j=1,nbrand
            if((pricesl(j).ne.0.).and.(derivsum(i,j,2).gt.-90.))then
               xxv(1,1,1)=xxv(1,1,1)+1.d0
               xxv(1,1,2)=xxv(1,1,2)+derivsum(i,j,2)
               xxv(1,2,2)=xxv(1,2,2)+(derivsum(i,j,2)*derivsum(i,j,2))
               xy(1,1)=xy(1,1)+pricesl(j)
               xy(1,2)=xy(1,2)+(derivsum(i,j,2)*pricesl(j))
               endif
            if((amilesl(j).ne.0.).and.(derivsum(i,j,2).gt.-90.))then
               xxv(2,1,1)=xxv(2,1,1)+1.d0
               xxv(2,1,2)=xxv(2,1,2)+derivsum(i,j,2)
               xxv(2,2,2)=xxv(2,2,2)+(derivsum(i,j,2)*derivsum(i,j,2))
               xy(2,1)=xy(2,1)+amilesl(j)
               xy(2,2)=xy(2,2)+(derivsum(i,j,2)*amilesl(j))
               endif
  28        continue
         do 31 j=1,2
            xx(1,1)=xxv(j,1,1)
            xx(1,2)=xxv(j,1,2)
            xx(2,2)=xxv(j,2,2)
            xx(2,1)=xx(1,2)
            d1=-1.d0
            call linv3f(xx,work1,1,n2,2,d1,d2,work2,ier)
            if(ier.gt.0)then
               write(6,118)i,ier
 118           format(1x,'inversion problem for i = ',i3,' ier = ',i3)
               stop
               endif
            do 31 k=1,2
  31           b(j,k)=(xx(k,1)*xy(j,1))+(xx(k,2)*xy(j,2))
         write(6,117)ameth(i)
 117     format(1x,'ols estimates for method = ',a8)
         do 32 j=1,2
            write(6,115)
 115        format(1x,'variable',2x,'estimate',4x,'std err',3x,
     &       't-statistic')
            ybar=0.d0
            tss=0.d0
            rss=0.d0
            nba=0
            do 7 k=1,nbrand
               if(j.eq.1)then
                  if((pricesl(k).eq.0.).or.(derivsum(i,k,2).le.-90.))
     &             goto 7
                  y=pricesl(k)
                  endif
               if(j.eq.2)then
                  if((amilesl(k).eq.0.).or.(derivsum(i,k,2).le.-90.))
     &             goto 7
                  y=amilesl(k)
                  endif
               nba=nba+1
               resols=y-(b(j,1)+(b(j,2)*derivsum(i,k,2)))
               ybar=ybar+y
               tss=tss+(y*y)
               rss=rss+(resols*resols)
   7           continue
            tss=tss-(ybar*ybar/nba)
            sigma2=rss/(nba-2)
            r2=1.d0-(rss/tss)
            do 4 k=1,2
               stderr=(xx(k,k)*sigma2)**.5d0
               tstat=b(j,k)/stderr
               atstat=abs(tstat)
               if(atstat.le.1.53)start=star(1)
               if((atstat.gt.1.53).and.(atstat.le.1.96))start=star(2)
               if(atstat.gt.1.96)start=star(3)
   4           write(6,116)avar(k),b(j,k),start,stderr,tstat
 116        format(1x,a8,2x,f8.4,a2,2(2x,f8.4))
            write(6,114)r2
 114        format(1x,/,1x,'r2 = ',f8.5)
  32        write(6,144)
 144     format(1x,50('-'))
  30     continue
      return
      end
c
c
      subroutine decompos2
c
c       this subroutine decomposes median derivatives of log mileage 
c       with respect to age into an age effect, a portfolio effect, and
c       a household demographics effect.  then it runs ols regressions 
c       of the effects on age effects on prices and on ols age effects 
c       on mileage.
c
      parameter(nages=13,nagep1s=nages+1,nbrs=23,nbr3s=nbrs+3,ncars=10,
     & ncarm1s=ncars-1,ncchars=80,nccharts=2,ndgrids=201,nhouses=11,
     & nobss=26000,nobsss=nobss*2,npolys=2)
      implicit real*8(a-h,o-z)
      character*2 star(3),start
      character*8 abrand(nbr3s),adepvar(2),ameth(3),amiss,avar(2)
      real hchar,propmil,summiles
      dimension akernmax(3,nbr3s),amilesl(nbr3s),amilesv(nobsss),b(2,2),
     & basemiles(ncars),deriv(3,nbr3s,nages,ndgrids),
     & derivsum(3,ndgrids),dresid(ncars,ncars),iaggv(nbr3s),iflag(3),
     & iflagm(3,nagep1s),prdsmmom(5),prdsmv(nobss),pricesl(nbr3s),
     & prop(ncars),quantv(3,nbr3s,nagep1s,3),resid(ncars),uhat(ncars),
     & work1(2),work2(4),xx(2,2),xxv(2,2,2),xy(2,2)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data adepvar/'prices','ols mile'/
      data ameth/'age','total','no demog'/
      data amiss/'  ----  '/
      data avar/'constant','slope'/
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
      data star/'  ','* ','**'/
c
c       initialize.
c
      call parset2
      imshr=2
      nbrand=26
      nage=10
      nagep1=nage+1
      ndgrid=201
      andgrid=dble(float(ndgrid))
      do 8 i=1,3
         do 8 j=1,nbrand
            do 46 k=2,3
  46           akernmax(k,j)=0.d0
            do 8 k=1,nage
               do 8 l=1,ndgrid
   8              deriv(i,j,k,l)=0.d0
c
c       compute bandwidth for kernel function.
c
      do 18 i=1,3
  18     prdsmmom(i)=0.d0
      prdsmmom(4)=1.d20
      prdsmmom(5)=-1.d20
      do 26 i=1,nobs
         prdsm=0.d0
         do 27 j=1,nhouse
  27        prdsm=prdsm+(gamma(j)*dble(hchar(i,j)))
         prdsmmom(1)=prdsmmom(1)+1.d0
         prdsmmom(2)=prdsmmom(2)+prdsm
         prdsmmom(3)=prdsmmom(3)+(prdsm*prdsm)
         if(prdsmmom(4).gt.prdsm)prdsmmom(4)=prdsm
         if(prdsmmom(5).lt.prdsm)prdsmmom(5)=prdsm
         prdsmv(i)=prdsm
  26     continue
      prdsmmom(2)=prdsmmom(2)/prdsmmom(1)
      prdsmmom(3)=((prdsmmom(3)/prdsmmom(1))-(prdsmmom(2)*prdsmmom(2)))
     & **.5d0
      bandconst=.25d0
      bandprd=prdsmmom(3)*bandconst
      write(6,113)(prdsmmom(i),i=2,5),bandprd
 113  format(1x,'moments for prdsm:',/,1x,'mean: ',g15.8,/,1x,
     & 'std dev: ',g15.8,/,1x,'minimum: ',g15.8,/,1x,'maximum: ',g15.8,
     & /,1x,'bandwidth for kernel: ',g15.8)
c
c       prepare for total derivative calculation.
c
      write(6,110)
      write(6,112)
 112  format(1x,'preparation')
      do 19 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
 100     format(1x,'i = ',i6)
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 13 j=1,ncart
  13           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute total miles for household.
c
         prdsm=prdsmv(i)
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
         call heval(ncart,prdsm,uhatl,h,1)
         basesum=exp(log(dble(summiles(i)))-h)
         if(ncart.le.1)then
            jj=index(i)+1
            amilesv(jj)=basesum
            endif
         if(ncart.gt.1)then
c
c       compute proportions and mileage for each car.
c
            do 33 j=1,ncart
               jj=index(i)+j
               prop(j)=dble(propmil(jj))-resid(j)
  33           amilesv(jj)=basesum*prop(j)
            endif
  19     continue
c
c       compute derivatives for each observation.
c
      do 2 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 3 j=1,ncart
   3           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute mileage for each car.
c       compute total miles for household.
c
         prdsm=prdsmv(i)
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
c
c       compute proportions and mileage for each car.
c
         do 5 j=1,ncart
            jj=index(i)+j
   5        basemiles(j)=amilesv(jj)
c
c       compute derivatives.
c
         do 6 j=1,ncart
            ij=index(i)+j
            iage=icchar(ij,2)+1
            if(iage.gt.10)iage=10
            icchar(ij,2)=icchar(ij,2)+1
            call shareinit
c
c       compute mileage for each car.
c
            call shareres(uhat,ncartm1,resid,dresid,0)
            call heval(ncart,prdsm,uhatl,h,1)
            dsum=exp(log(dble(summiles(i)))-h)
            if(ncart.le.1)dmiles=(dsum-basemiles(1))/basemiles(1)
            if(ncart.gt.1)then
               jj=index(i)+j
               dpropj=dble(propmil(jj))-resid(j)
               dmiles=((dsum*dpropj)-basemiles(j))/basemiles(j)
               endif
c
c       compute total effect (including household demographic effects 
c       and portfolio effects) and compute total effect minus portfolio
c       effect.
c
            ibrand=iaggv(icchar(ij,1))
            derivmax=0.d0
            do 16 k=1,nobs
               if(k.eq.i)goto 16
               ncartc=ncar(k)
c
c       measure distance between household and candidate other 
c       household.
c       check for match on brand and age.
c
               do 17 l=1,ncartc
                  kl=index(k)+l
                  lbrand=iaggv(icchar(kl,1))
                  if(lbrand.eq.ibrand)then
                     iagec=icchar(kl,2)
                     if(iagec.gt.10)iagec=10
                     if(iagec.eq.iage)then
c
c       match on brand.  check for household demographic match.
c
                        prdsmc=prdsmv(k)
                        call kernel(prdsm,prdsmc,bandprd,akern)
                        dmt=(amilesv(kl)-basemiles(j))/basemiles(j)
                        if(dmt.gt..5)dmt=.5d0
                        if(dmt.lt.-.5)dmt=-.5d0
                        idgrid=((dmt+.499d0)*ndgrid)+1
                        if(idgrid.eq.0)idgrid=1
                        deriv(2,ibrand,iage,idgrid)=
     &                   deriv(2,ibrand,iage,idgrid)+1.d0
                        deriv(3,ibrand,iage,idgrid)=
     &                   deriv(3,ibrand,iage,idgrid)+akern
                        derivmax=derivmax+1.d0
                        if(akernmax(2,ibrand).lt.akern)
     &                   akernmax(2,ibrand)=akern
                        endif
                     endif
  17              continue
  16           continue
c
c       update derivative moments.
c
            if(dmiles.lt.-.5)dmiles=-.5d0
            if(dmiles.gt..5)dmiles=.5d0
            idgrid=((dmiles+.499d0)*ndgrid)+1
            if(idgrid.eq.0)idgrid=1
            deriv(1,ibrand,iage,idgrid)=deriv(1,ibrand,iage,idgrid)+1.d0
            if(akernmax(3,ibrand).lt.derivmax)akernmax(3,ibrand)=
     &       derivmax
   6        icchar(ij,2)=icchar(ij,2)-1
   2     continue
c
c       adjust moments and output.
c
      do 10 i=1,nbrand
         write(6,110)
 110     format(1x,50('='))
         write(6,110)
         write(6,102)abrand(i)
 102     format(1x,'medians of derivatives for ',a8)
         iflagtot=0
         do 14 j=1,3
            write(6,110)
            write(6,107)ameth(j)
 107        format(1x,'using method: ',a8)
            do 12 k=1,ndgrid
  12           derivsum(j,k)=0.d0
            iflag(j)=0
            do 11 k=1,nage
               derivtot=0.d0
               do 25 l=1,ndgrid
                  derivtot=derivtot+deriv(j,i,k,l)
  25              derivsum(j,l)=derivsum(j,l)+deriv(j,i,k,l)
               iflagm(j,k)=0
               if(derivtot.gt.0.)then
                  iflagm(j,k)=1
                  iflagtot=1
                  if(iflag(j).eq.0)then
                     write(6,101)
 101                 format(1x,'age',6x,'mass',13x,'1st quantile',2x,
     &                'median',8x,'3rd quantile')
                     iflag(j)=1
                     iflagtot=1
                     endif
                  quant=.25d0
                  iquant=1
                  dist=0.d0
                  do 24 l=1,ndgrid
                     deriv(j,i,k,l)=deriv(j,i,k,l)/derivtot
                     dist=dist+deriv(j,i,k,l)
  23                 continue
                     if(dist.ge.quant)then
                        if(iquant.gt.3)goto 24
                        quantv(j,i,k,iquant)=(dble(float(l-1))/andgrid)-
     &                   .499d0
                        quant=quant+.25d0
                        iquant=iquant+1
                        goto 23
                        endif
  24                 continue
                  write(6,111)k,derivtot,(quantv(j,i,k,l),l=1,3)
 111              format(1x,i2,7x,g15.8,2x,3(f8.4,6x))
                  endif
  11           continue
            if(iflag(j).eq.1)then
               derivtot=0.d0
               do 22 k=1,ndgrid
  22              derivtot=derivtot+derivsum(j,k)
               quant=.25d0
               iquant=1
               dist=0.d0
               do 21 k=1,ndgrid
                  derivsum(j,k)=derivsum(j,k)/derivtot
                  dist=dist+derivsum(j,k)
  20              continue
                  if(dist.ge.quant)then
                     if(iquant.gt.3)goto 21
                     medsav=k
                     quantv(j,i,nagep1,iquant)=(dble(float(k-1))/
     &                andgrid)-.499d0
                     quant=quant+.25d0
                     iquant=iquant+1
                     goto 20
                     endif
  21              continue
               write(6,109)derivtot,(quantv(j,i,nagep1,k),k=1,3)
 109           format(1x,'average',2x,g15.8,2x,3(f8.4,6x))
               densmed=0.d0
               ib=medsav-10
               if(ib.lt.2)ib=2
               ie=medsav+10
               if(ie.ge.ndgrid)ie=ndgrid-1
               densmedn=0.d0
               do 45 k=ib,ie
  45              densmedn=densmedn+derivsum(j,k)
               densmedd=dble(float(ie-ib))/andgrid
               densmed=densmedn/densmedd
               if(j.gt.1)stdmed=(1.d0/(4.d0*derivtot*densmed*densmed/
     &          akernmax(j,i)))**.5d0
               if(j.eq.1)stdmed=(1.d0/(4.d0*derivtot*densmed*densmed))
     &          **.5d0
               write(6,145)stdmed
 145           format(1x,/,1x,'std err of estimate of median = ',g15.8)
               endif
  14        continue
         write(6,108)(ameth(j),j=1,3)
 108     format(1x,'comparison of medians across decompositions',/,1x,
     &    'age',4x,3(2x,a8))
         do 9 j=1,nage
            if(iflagm(1,j).eq.1)then
               if(iflagm(2,j).eq.1)then
                  if(iflagm(3,j).eq.1)write(6,106)j,(quantv(k,i,j,2),
     &             k=1,3)
 106              format(1x,i2,5x,3(2x,f8.4))
                  if(iflagm(3,j).eq.0)write(6,121)j,(quantv(k,i,j,2),
     &             k=1,2),amiss
 121              format(1x,i2,5x,2(2x,f8.4),2x,a8)
                  endif
               if(iflagm(2,j).eq.0)then
                  if(iflagm(3,j).eq.1)write(6,122)j,quantv(1,i,j,2),
     &             amiss,quantv(3,i,j,2)
 122              format(1x,i2,7x,f8.4,2x,a8,2x,f8.4)
                  if(iflagm(3,j).eq.0)write(6,123)j,quantv(1,i,j,2),
     &             amiss,amiss
 123              format(1x,i2,7x,f8.4,2(2x,a8))
                  endif
               endif
            if(iflagm(1,j).eq.0)then
               if(iflagm(2,j).eq.1)then
                  if(iflagm(3,j).eq.1)write(6,124)j,amiss,
     &             (quantv(k,i,j,2),k=2,3)
 124              format(1x,i2,7x,a8,2(2x,f8.4))
                  if(iflagm(3,j).eq.0)write(6,125)j,amiss,
     &             quantv(2,i,j,2),amiss
 125              format(1x,i2,7x,a8,2x,f8.4,2x,a8)
                  endif
               if(iflagm(2,j).eq.0)then
                  if(iflagm(3,j).eq.1)write(6,126)j,amiss,amiss,
     &             quantv(3,i,j,2)
 126              format(1x,i2,5x,2(2x,a8),2x,f8.4)
                  if(iflagm(3,j).eq.0)write(6,127)j,(amiss,k=1,3)
 127              format(1x,i2,5x,3(2x,a8))
                  endif
               endif
   9        continue
         if(iflag(1).eq.1)then
            if(iflag(2).eq.1)then
               if(iflag(3).eq.1)write(6,105)(quantv(j,i,nagep1,2),
     &          j=1,3)
 105           format(1x,'average',3(2x,f8.4))
               if(iflag(3).eq.0)write(6,128)(quantv(j,i,nagep1,2),
     &          j=1,2),amiss
 128           format(1x,'average',2(2x,f8.4),2x,a8)
               endif
            if(iflag(2).eq.0)then
               if(iflag(3).eq.1)write(6,129)quantv(1,i,nagep1,2),amiss,
     &          quantv(3,i,nagep1,2)
 129           format(1x,'average',2x,f8.4,2x,a8,2x,f8.4)
               if(iflag(3).eq.0)write(6,130)quantv(1,i,nagep1,2),
     &          (amiss,j=1,2)
 130           format(1x,'average',2x,f8.4,2(2x,a8))
               endif
            endif
         if(iflag(1).eq.0)then
            if(iflag(2).eq.1)then
               if(iflag(3).eq.1)write(6,131)amiss,
     &          (quantv(j,i,nagep1,2),j=2,3)
 131           format(1x,'average',2x,a8,2(2x,f8.4))
               if(iflag(3).eq.0)write(6,132)amiss,quantv(2,i,nagep,2),
     &          amiss
 132           format(1x,'average',2x,a8,2x,f8.4,2x,a8)
               endif
            if(iflag(2).eq.0)then
               if(iflag(3).eq.1)write(6,133)(amiss,j=1,2),
     &          quantv(3,i,nagep1,2)
 133           format(1x,'average',2(2x,a8),2x,f8.4)
               if(iflag(3).eq.0)write(6,134)(amiss,j=1,3)
 134           format(1x,'average',3(2x,a8))
               endif
            endif
         write(6,119)
         if(iflagtot.eq.1)then
            write(6,104)(ameth(j),j=1,3)
 104        format(1x,'density of average derivative',/,1x,'slope',1x,
     &       3(2x,a8))
            if(iflag(1).eq.1)then
               if(iflag(2).eq.1)then
                  if(iflag(3).eq.1)then
                     do 15 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  15                    write(6,103)aval,(derivsum(k,j),k=1,3)
 103                 format(1x,f6.3,3(2x,f8.4))
                     endif
                  if(iflag(3).eq.0)then
                     do 35 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  35                    write(6,135)aval,(derivsum(k,j),k=1,2),amiss
 135                 format(1x,f6.3,2(2x,f8.4),2x,a8)
                     endif
                  endif
               if(iflag(2).eq.0)then
                  if(iflag(3).eq.1)then
                     do 36 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  36                    write(6,136)aval,derivsum(1,j),amiss,
     &                   derivsum(3,j)
 136                 format(1x,f6.3,2x,f8.4,2x,a8,2x,f8.4)
                     endif
                  if(iflag(3).eq.0)then
                     do 37 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  37                    write(6,137)aval,derivsum(1,j),(amiss,k=1,2)
 137                 format(1x,f6.3,2x,f8.4,2(2x,a8))
                     endif
                  endif
               endif
            if(iflag(1).eq.0)then
               if(iflag(2).eq.1)then
                  if(iflag(3).eq.1)then
                     do 38 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  38                    write(6,138)aval,amiss,(derivsum(k,j),k=2,3)
 138                 format(1x,f6.3,2x,a8,2(2x,f8.4))
                     endif
                  if(iflag(3).eq.0)then
                     do 39 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  39                    write(6,139)aval,amiss,derivsum(2,j),amiss
 139                 format(1x,f6.3,2x,a8,2x,f8.4,2x,a8)
                     endif
                  endif
               if(iflag(2).eq.0)then
                  if(iflag(3).eq.1)then
                     do 40 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  40                    write(6,140)aval,(amiss,k=1,2),derivsum(3,j)
 140                 format(1x,f6.3,2(2x,a8),2x,f8.4)
                     endif
                  if(iflag(3).eq.0)then
                     do 41 j=1,ndgrid
                        aval=(dble(float(j-1))/andgrid)-.499d0
  41                    write(6,141)aval,(amiss,k=1,3)
 141                 format(1x,f6.3,3(2x,a8))
                     endif
                  endif
               endif
            endif
  10     continue
c
c       run regressions on averages.
c
      write(6,110)
      open(unit=8,file='olsdata.prn')
      do 34 i=1,nbrand
  34     read(8,120)amilesl(i),pricesl(i)
 120  format(16x,f8.4,8x,f8.3)
      close(8)
      n2=2
      do 30 i=1,3
         do 29 j=1,2
            do 29 k=1,2
               xy(j,k)=0.d0
               do 29 l=1,2
  29              xxv(j,k,l)=0.d0
         do 28 j=1,nbrand
            if((pricesl(j).ne.0.).and.(quantv(i,j,nagep1,2).gt.-.5))then
               xxv(1,1,1)=xxv(1,1,1)+1.d0
               xxv(1,1,2)=xxv(1,1,2)+quantv(i,j,nagep1,2)
               xxv(1,2,2)=xxv(1,2,2)+(quantv(i,j,nagep1,2)*
     &          quantv(i,j,nagep1,2))
               xy(1,1)=xy(1,1)+pricesl(j)
               xy(1,2)=xy(1,2)+(quantv(i,j,nagep1,2)*pricesl(j))
               endif
            if((amilesl(j).ne.0.).and.(quantv(i,j,nagep1,2).gt.-.5))then
               xxv(2,1,1)=xxv(2,1,1)+1.d0
               xxv(2,1,2)=xxv(2,1,2)+quantv(i,j,nagep1,2)
               xxv(2,2,2)=xxv(2,2,2)+(quantv(i,j,nagep1,2)*
     &          quantv(i,j,nagep1,2))
               xy(2,1)=xy(2,1)+amilesl(j)
               xy(2,2)=xy(2,2)+(quantv(i,j,nagep1,2)*amilesl(j))
               endif
  28        continue
         do 31 j=1,2
            xx(1,1)=xxv(j,1,1)
            xx(1,2)=xxv(j,1,2)
            xx(2,2)=xxv(j,2,2)
            xx(2,1)=xx(1,2)
            d1=-1.d0
            call linv3f(xx,work1,1,n2,2,d1,d2,work2,ier)
            if(ier.gt.0)then
               write(6,118)i,ier
 118           format(1x,'inversion problem for i = ',i3,' ier = ',i3)
               stop
               endif
            do 31 k=1,2
  31           b(j,k)=(xx(k,1)*xy(j,1))+(xx(k,2)*xy(j,2))
         write(6,117)ameth(i)
 117     format(1x,'ols estimates for method = ',a8)
         do 32 j=1,2
            ybar=0.d0
            tss=0.d0
            rss=0.d0
            nba=0
            iflagw=0
            do 7 k=1,nbrand
               if(j.eq.1)then
                  if((pricesl(k).eq.0.).or.(quantv(i,k,nagep1,2).le.
     &             -.5))goto 7
                  y=pricesl(k)
                  endif
               if(j.eq.2)then
                  if((amilesl(k).eq.0.).or.(quantv(i,k,nagep1,2).le.
     &             -.5))goto 7
                  y=amilesl(k)
                  endif
               nba=nba+1
               resols=y-(b(j,1)+(b(j,2)*quantv(i,k,nagep1,2)))
               if(iflagw.eq.0)then
                  write(6,143)adepvar(j)
 143              format(1x,'data for ols equation with dependent',
     &             ' variable = ',a8,/,1x,'variable',2x,'dep var',3x,
     &             'expl var')
                  iflagw=1
                  endif
               write(6,142)abrand(k),y,quantv(i,k,nagep1,2)
 142           format(1x,a8,2(2x,f8.4))
               ybar=ybar+y
               tss=tss+(y*y)
               rss=rss+(resols*resols)
   7           continue
            write(6,115)
 115        format(1x,'variable',2x,'estimate',4x,'std err',3x,
     &       't-statistic')
            tss=tss-(ybar*ybar/nba)
            sigma2=rss/(nba-2)
            r2=1.d0-(rss/tss)
            do 4 k=1,2
               stderr=(xx(k,k)*sigma2)**.5d0
               tstat=b(j,k)/stderr
               atstat=abs(tstat)
               if(atstat.le.1.53)start=star(1)
               if((atstat.gt.1.53).and.(atstat.le.1.96))start=star(2)
               if(atstat.gt.1.96)start=star(3)
   4           write(6,116)avar(k),b(j,k),start,stderr,tstat
 116        format(1x,a8,2x,f8.4,a2,2(2x,f8.4))
            write(6,114)r2
 114        format(1x,/,1x,'r2 = ',f8.5)
  32        write(6,119)
 119     format(1x,50('-'))
  30     continue
      return
      end
c
c
      subroutine demogderiv
c
c       this subroutine computes the distribution of derivatives with 
c       respect to demographic characteristics of the household 
c       disaggregated by brand and age.
c
      parameter(nages=13,nbrs=23,nbr3s=nbrs+3,ncars=10,ncarm1s=ncars-1,
     & ncchars=80,nccharts=2,ndemogs=6,nhouses=11,nobss=26000,
     & nobsss=nobss*2,npolys=2)
      implicit real*8(a-h,o-z)
      character*8 abrand(nbr3s),ademog(ndemogs)
      real hchar,propmil,summiles
      dimension basemiles(ncars),deriv(ndemogs,nbr3s,nages,5),
     & derivsum(5),dresid(ncars,ncars),iaggv(nbr3s),idemotr(ndemogs),
     & prop(ncars),resid(ncars),uhat(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data ademog/'lincome','urban','drvrs','adrvrs','mdrvrs','wdrvrs'/
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
      data idemotr/2,3,4,6,8,10/
      data small/-1.d-3/
c
c       initialize.
c
      call parset2
      imshr=2
      nbrand=26
      nage=10
      ndemog=6
      do 8 i=1,ndemog
         do 8 j=1,nbrand
            do 8 k=1,nage
               do 9 l=1,3
   9              deriv(i,j,k,l)=0.d0
               deriv(i,j,k,4)=1.d20
   8           deriv(i,j,k,5)=-1.d20
c
c       compute derivatives for each observation.
c
      do 2 i=1,nobs
         if(((i/100)*100).eq.i)write(6,100)i
 100     format(1x,'i = ',i6)
         iobs=i
         call shareinit
c
c       compute errors.
c
         ncart=ncar(i)
         ncartm1=ncart-1
         if(ishare.eq.0)then
            do 3 j=1,ncart
   3           uhat(j)=0.d0
            call share(uhat,ncartm1,objt)
            endif
         if((ishare.eq.1).or.(ishare.eq.2))then
            if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
            if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
            endif
         call hconst(ncart,uhat)
c
c       compute mileage for each car.
c       compute household characteristics term.
c
         prdsm=0.d0
         do 4 j=1,nhouse
   4        prdsm=prdsm+(gamma(j)*dble(hchar(i,j)))
c
c       compute total miles for household.
c
         call shareres(uhat,ncartm1,resid,dresid,0)
         uhatl=uhat(ncart)
         call heval(ncart,prdsm,uhatl,h,1)
         basesum=exp(log(dble(summiles(i)))-h)
         if(ncart.le.1)basemiles(1)=basesum
         if(ncart.gt.1)then
c
c       compute proportions and mileage for each car.
c
            do 5 j=1,ncart
               jj=index(i)+j
               prop(j)=dble(propmil(jj))-resid(j)
   5           basemiles(j)=basesum*prop(j)
            endif
c
c       compute derivatives.
c
         do 15 j=1,ndemog
            idemo=idemotr(j)
            idemop1=idemo+1
            hchar(i,idemo)=hchar(i,idemo)+.01
            if((j.gt.3).and.(hchar(i,idemop1).lt.2.))hchar(i,idemop1)=
     &       hchar(i,idemop1)+.01
            prdsm=0.d0
            do 16 k=1,nhouse
  16           prdsm=prdsm+(gamma(k)*dble(hchar(i,k)))
            call shareinit
c
c       compute mileage for each car.
c
            call shareres(uhat,ncartm1,resid,dresid,0)
            call heval(ncart,prdsm,uhatl,h,1)
            dsum=exp(log(dble(summiles(i)))-h)
            do 6 k=1,ncart
               ik=index(i)+k
               iage=icchar(ik,2)+1
               if(iage.gt.10)iage=10
               if(ncart.le.1)dmiles=100.d0*(dsum-basemiles(1))/
     &          basemiles(1)
               ibrand=iaggv(icchar(ik,1))
               if(ncart.gt.1)then
                  dpropk=dble(propmil(ik))-resid(k)
                  dmiles=100.d0*((dsum*dpropk)-basemiles(k))/
     &             basemiles(k)
                  endif
c
c       update derivative moments.
c
               deriv(j,ibrand,iage,1)=deriv(j,ibrand,iage,1)+1.d0
               deriv(j,ibrand,iage,2)=deriv(j,ibrand,iage,2)+dmiles
               deriv(j,ibrand,iage,3)=deriv(j,ibrand,iage,3)+(dmiles*
     &          dmiles)   
               if(deriv(j,ibrand,iage,4).gt.dmiles)
     &          deriv(j,ibrand,iage,4)=dmiles   
               if(deriv(j,ibrand,iage,5).lt.dmiles)
     &          deriv(j,ibrand,iage,5)=dmiles
   6           continue
            hchar(i,idemo)=hchar(i,idemo)-.01
            if((j.gt.3).and.(hchar(i,idemop1).lt.2.))hchar(i,idemop1)=
     &       hchar(i,idemop1)-.01
  15        continue
   2     continue
c
c       adjust moments and output.
c
      do 14 i=1,ndemog
         write(6,110)
 110     format(1x,50('='))
         write(6,102)ademog(i)
 102     format(1x,'moments of derivatives for ',a8,/,1x,'brand',5x,
     &    'age',7x,'# obs',3x,'mean',6x,'std dev',3x,'minimum',3x,
     &    'maximum')
         do 10 j=1,nbrand
            do 12 k=1,3
  12           derivsum(k)=0.d0
            derivsum(4)=1.d20
            derivsum(5)=-1.d20
            iflag=0
            do 11 k=1,nage
               if(deriv(i,j,k,1).gt.0.)then
                  do 25 l=1,3
  25                 derivsum(l)=derivsum(l)+deriv(i,j,k,l)
                  if(derivsum(4).gt.deriv(i,j,k,4))derivsum(4)=
     &             deriv(i,j,k,4)
                  if(derivsum(5).lt.deriv(i,j,k,5))derivsum(5)=
     &             deriv(i,j,k,5)
                  if(deriv(i,j,k,1).le.3)then
                     if(iflag.eq.0)then
                        write(6,101)abrand(j)
                        iflag=1
                        endif
                     write(6,104)k,deriv(i,j,k,1)
 104                 format(11x,i2,3x,f6.1)
                     endif
                  if(deriv(i,j,k,1).gt.3)then
                     deriv(i,j,k,2)=deriv(i,j,k,2)/deriv(i,j,k,1)
                     deriv(i,j,k,3)=(deriv(i,j,k,3)/deriv(i,j,k,1))-
     &                (deriv(i,j,k,2)*deriv(i,j,k,2))
                     if(deriv(i,j,k,3).gt.0.)deriv(i,j,k,3)=
     &                deriv(i,j,k,3)**.5d0
                     if((deriv(i,j,k,3).le.0.).and.(deriv(i,j,k,3).gt.
     &                small))deriv(i,j,k,3)=0.d0
                     if(deriv(i,j,k,3).le.small)then
                        write(6,155)i,j,k,deriv(i,j,k,3)
 155                    format(1x,'problem with deriv(',i2,',',i2,',',
     &                   i2,',3):  ',g15.8)
                        stop
                        endif
                     if(iflag.eq.0)then
                        write(6,101)abrand(j)
 101                    format(1x,a8)
                        iflag=1
                        endif
                     write(6,103)k,(deriv(i,j,k,l),l=1,5)
 103                 format(11x,i2,8x,f6.1,4(2x,f8.4))
                     endif
                  endif
  11           continue
            if(derivsum(1).le.3.)write(6,106)abrand(j),derivsum(1)
 106        format(1x,a8,2x,'average',1x,f8.1)
            if(derivsum(1).gt.3.)then
               derivsum(2)=derivsum(2)/derivsum(1)
               derivsum(3)=(derivsum(3)/derivsum(1))-(derivsum(2)*
     &          derivsum(2))
               if(derivsum(3).gt.0.)derivsum(3)=derivsum(3)**.5d0
               if((derivsum(3).le.0.).and.(derivsum(3).gt.small))
     &          derivsum(3)=0.d0
               if(derivsum(3).le.small)then
                  write(6,156)i,j,derivsum(3)
 156              format(1x,'problem with derivsum(3) for i = ',i2,
     &             ', j = ',i2,':  ',g15.8)
                  stop
                  endif
               write(6,105)(derivsum(k),k=1,5)
 105           format(11x,'average',1x,f8.1,4(2x,f8.4))
               endif
  10        continue
  14     continue
      return
      end
c
c
      subroutine estim(parm,nparm)
c
c       this subroutine estimates the parameters of the model using 
c       simplex.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 alabel
      dimension parm(ncoefs),parmold(ncoefs)
      common/best/fbest(3)
      common/bnel/stp,var,konvge,nrst
      common/bstack/aint(10000)
      common/bstak/nq,ntop
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      external likely,nmsimp
      do 8 i=1,3
   8     fbest(i)=-1.d20
      niter=50
      mx=1
      acc=.1d-4
      nrst=5
      nq=(nparm*nparm)+(4*nparm)+1
      do 4 i=1,nparm
   4     parmold(i)=parm(i)
      call likely(parm,nparm,objold,ier)
      do 2 i=1,8
         stp=.03d0
         call opt(parm,nparm,obj,nmsimp,niter,mx,ier,acc,likely,alabel)
         parm2=0.d0
         do 3 j=1,nparm
            dparm=parm(j)-parmold(j)
            parmold(j)=parm(j)
   3        parm2=parm2+(dparm*dparm)
         parm2=(parm2/nparm)**.5d0
         dobj=abs(obj-objold)/objold
         write(6,101)i,parm2,dobj
 101     format(1x,'iteration ',i1,': parm2 = ',g15.8,' dobj = ',g15.8)
         if((parm2.lt..1d-2).and.(abs(dobj).lt..1d-4))then
            write(6,100)
 100        format(1x,'convergence reached')
            call covar(parm)
            return
            endif
         objold=obj
   2     continue
   5  continue
      write(6,102)
 102  format(1x,'no convergence reached')
      stop
      end
c
c
      subroutine estimalt(parm,nparm)
c
c       this subroutine estimates parm using a crude step-in-best-
c       direction algorithm.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 adir(2)
      dimension igood(ncoefs),parm(ncoefs)
      data adir/'increase','decrease'/
      call likely(parm,nparm,f,ier)
      fbest=f
      niter=10
      iterb=0
   5  iterb=iterb+1
      do 3 i=1,nparm
   3     igood(i)=1
      iter=0
   4  iter=iter+1
      ianygo=0
      do 2 i=1,nparm
         if(igood(i).eq.1)then
            delta=abs(parm(i))/250.d0
            if(delta.lt..1d-3)delta=.1d-1
            if(delta.gt..1)delta=.1d1
            parm(i)=parm(i)+delta
            call likely(parm,nparm,f,ier)
            if(f.gt.fbest)then
               write(6,100)adir(1),delta,i,fbest,f,(parm(j),j=1,nparm)
 100           format(1x,'improvement with ',a8,' of ',f6.4,
     &          ' in parameter ',i3,':',/,1x,'old f = ',g15.8,
     &          ', new f = ',g15.8,/,1x,'parm = ',50(/,5(1x,g15.8)))
               fbest=f
               ianygo=1
               goto 2
               endif
            parm(i)=parm(i)-(2.d0*delta)
            call likely(parm,nparm,f,ier)
            if(f.gt.fbest)then
               write(6,100)adir(2),delta,i,fbest,f,(parm(j),j=1,nparm)
               fbest=f
               ianygo=1
               goto 2
               endif
            parm(i)=parm(i)+delta
            igood(i)=0
            write(6,104)i
 104        format(1x,'no improvement for parameter ',i3)
            endif
   2     continue
      if((ianygo.eq.1).and.(iter.lt.niter))goto 4
      if(ianygo.eq.0)write(6,101)
 101  format(1x,'no improvements left')
      if(iter.ge.niter)write(6,102)niter
 102  format(1x,'maximum iterations: ',i3)
      if(iterb.le.8)goto 5
      return
      end
c
c
      subroutine estimamoeba(parm,nparm)
c
c       this subroutine uses the numerical methods simplex method 
c       instead of the gqopt simplex method to estimate the model.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s,ncoef1s=
     & ncoefs+1)
      implicit real*8(a-h,o-z)
      dimension obj(ncoef1s),parm(ncoefs),parmold(ncoefs),
     & simplex(ncoef1s,ncoefs),simpt(ncoefs)
      common/best/fbest(3)
      external likelypass
c
c       initialize.
c
      stp1=.01
      ftol=.2d-4
      ytol=.1d-4
      do 18 i=1,3
  18     fbest(i)=-1.d20
c
c       do simplex until convergence.
c
      do 2 i=1,20
c
c       initialize for simplex method.
c
         do 3 j=1,nparm
            simplex(1,j)=parm(j)
   3        parmold(j)=parm(j)
         do 7 j=1,nparm
   7        simpt(j)=simplex(1,j)
         call likelypass(simpt,nparm,objt)
         obj(1)=objt
         objold=obj(1)
         do 4 j=1,nparm
            jp1=j+1
            do 5 k=1,nparm
   5           simplex(jp1,k)=simplex(1,k)
            simplex(jp1,j)=simplex(jp1,j)+stp1
            do 6 k=1,nparm
   6           simpt(k)=simplex(jp1,k)
            call likelypass(simpt,nparm,objt)
   4        obj(jp1)=objt
         call amoebaout(simplex,obj,nparm,ftol,likelypass,iter,ibest,
     &    ytol)
         do 8 j=1,nparm  
   8        parm(j)=simplex(ibest,j)
         if(obj(ibest).lt.ftol)then
            call likelypass(parm,nparm,objt)
            return
            endif
         parm2=0.d0
         do 9 j=1,nparm  
            dparm=parm(j)-parmold(j)
   9        parm2=parm2+(dparm*dparm)
         parm2=parm2/nparm
         dobj=abs(obj(ibest)-objold)/objold
         write(6,101)i,parm2,dobj
 101     format(1x,'iter = ',i2,' parm2 = ',g15.8,' dobj = ',g15.8)
         if((parm2.lt..001).and.(dobj.lt..1d-3))then
            call likelypass(parm,nparm,objt)
            call covar(parm)
            return
            endif
   2     continue
      write(6,100)
 100  format(1x,'no convergence')
      return
      end
c
c
      subroutine gridsrch
c
c       this subroutine does a grid search for a subset of parameters.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=ncars-1,
     & ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 alabel
      dimension begg(3),delta(3),igrd(3),obj(11,11),parm(ncoefs)
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      common/wdiagn/iwrite
c
c       check if too many parameters.
c
      ico=0
      do 2 i=1,ncoef
         if(icoef(i).eq.0)then
            ico=ico+1
            if(ico.gt.3)then
               write(6,100)(icoef(j),j=1,ncoef)
 100           format(1x,'too many dimensions (must be < 4);',/,1x,
     &          'icoef:',10(/,1x,10(2x,i2)))
               return
               endif
            igrd(ico)=i
            endif
   2     continue
      if(ico.eq.0)then
         write(6,101)
 101     format(1x,'no variables in grid search')
         return
         endif
c
c       set up grids.
c
      do 3 i=1,ico
         igrdt=igrd(i)
         delta(i)=abs(coef(igrdt))/10.d0
         if(delta(i).lt..1)delta(i)=.1d0
   3     begg(i)=coef(igrdt)-(5.d0*delta(i))
c
c       do grid search if only one dimension.
c
      if(ico.eq.1)then
         parmt=begg(ico)-delta(ico)
         write(6,103)
 103     format(1x,'i',4x,'parm',6x,'obj')
         do 4 i=1,11
            parmt=parmt+delta(ico)
            parm(ico)=parmt
            call likely(parm,ico,objt,ier)
            objt=-1.d-3*objt
   4        write(6,102)i,parm(ico),objt
 102     format(1x,i3,2x,f8.3,2x,f8.5)
         endif
c
c       do grid search if two dimensions.
c
      if(ico.eq.2)then
         parm(1)=begg(1)-delta(1)
         write(6,105)(begg(2)+((j-1)*delta(2)),j=1,11)
 105     format(1x,'value',3x,11(2x,f8.3))
         do 5 i=1,11
            parm(1)=parm(1)+delta(1)
            parm(2)=begg(2)-delta(2)
            do 6 j=1,11
c
c              iwrite=0
c              if(i.eq.1)then
c                 if((j.eq.2).or.(j.eq.4).or.(j.eq.6).or.(j.eq.9))then
c                    iwrite=1
c                    write(6,555)i,j
c555                 format(1x,'iwrite on, i = ',i2,' j = ',i2)
c                    endif
c                 endif
c
               parm(2)=parm(2)+delta(2)
               call likely(parm,2,objt,ier)
   6           obj(j,1)=-1.d-3*objt
   5        write(6,104)parm(1),(obj(j,1),j=1,11)
 104     format(1x,f8.3,11(2x,f8.5))
         endif
c
c       do grid search if three dimensions.
c
      if(ico.eq.3)then
         parm(1)=begg(1)-delta(1)
         do 7 i=1,11
            parm(1)=parm(1)+delta(1)
            write(6,106)parm(1),(begg(2)+((j-1)*delta(2)),j=1,11)
 106        format(1x,'matrix for parm(1) = ',f8.3,/,1x,'value',3x,
     &       11(2x,f8.3))
            parm(2)=begg(2)-delta(2)
            do 8 j=1,11
               parm(2)=parm(2)+delta(2)
               parm(3)=begg(3)-delta(3)
               do 9 k=1,11
                  parm(3)=parm(3)+delta(3)
                  call likely(parm,3,objt,ier)
   9              obj(j,k)=-1.d-3*objt
   8           write(6,104)parm(2),(obj(j,k),k=1,11)
   7        continue
         endif
      return
      end
c
c
      subroutine hconst(ncart,uhat)
c
c       this subroutine finds the value of uhat that solves the h 
c       function.
c
      parameter(nobss=26000,nobsss=nobss*2,ncars=10,ncarm1s=ncars-1,
     & ncchars=80,nccharts=2,nhouses=11,npolys=2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension uhat(ncars)
      common/icohcos/icohco
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
c
c       compute household characteristics term.
c
      prdsm=0.d0
      do 2 i=1,nhouse
   2     prdsm=prdsm+(gamma(i)*dble(hchar(iobs,i)))
c
c       use a bisection program to solve for h.
c       set lower and upper limits.
c
      uup=5.d0*sigu
      udown=-uup
      icohco=icohco+1
c     if(((icohco/100000)*100000).eq.icohco)write(6,444)icohco
 444  format(1x,'icohco = ',i8)
c
c       evaluate h at upper and lower bounds.
c
      call heval(ncart,prdsm,uup,hup,1)
      if(hup.gt.0.)then
         hupo=hup
         iext=0
   7     iext=iext+1
         if(iext.eq.9)hup9=hup
         if(iext.eq.10)hup10=hup
         if(iext.gt.10)then
            su=2.d0*(hup10-hup9)/uup
            au=hup10-(su*uup)
            umid=(-1.d0*au/su)
            uhat(ncart)=umid
            do 10 i=1,ncartm1
  10           uhat(i)=uhat(i)+umid
            return
            endif
         uup=uup*2.d0
         call heval(ncart,prdsm,uup,hup,1)
         if(hup.le.0.)then
            udown=uup/2.d0
            call heval(ncart,prdsm,udown,hdown,1)
            goto 6
            endif
         if(hup.ge.hupo)then
            write(6,101)hup,hupo
 101        format(1x,'bad difference in heval: hup = ',g15.8,
     &       ' hupo = ',g15.8)
            write(6,444)icohco
            stop
            endif
         goto 7
         endif
      call heval(ncart,prdsm,udown,hdown,1)
      if(hdown.lt.0.)then
         hdowno=hdown
         iext=0
   8     iext=iext+1
         if(iext.eq.9)hdown9=hdown
         if(iext.eq.10)hdown10=hdown
         if(iext.gt.10)then
            su=2.d0*(hdown10-hdown9)/udown
            au=hdown10-(su*udown)
            umid=(-1.d0*au/su)
            uhat(ncart)=umid
            do 9 i=1,ncartm1
   9           uhat(i)=uhat(i)+umid
            return
            endif
         udown=udown*2.d0
         call heval(ncart,prdsm,udown,hdown,1)
         if(hdown.ge.0.)then
            uup=udown/2.d0
            call heval(ncart,prdsm,uup,hup,1)
            goto 6
            endif
         if(hdown.le.hdowno)then
            write(6,102)hdown,hdowno
 102        format(1x,'bad difference in heval: hdown = ',g15.8,
     &       ' hdowno = ',g15.8)
            write(6,444)icohco
            stop
            endif
         goto 8
         endif
c
c       evaluate h at midpoint.
c
   6  iter=0
   3  continue
      range=uup-udown
      if(iter.lt.5)then
         slope=(hup-hdown)/(uup-udown)
         aintcpt=hup-(slope*uup)
         umid=(-1.d0)*aintcpt/slope
         small=.1d-2*range
         if(((umid-udown).lt.small).or.((uup-umid).lt.small))umid=(uup+
     &   udown)/2.d0
         endif
      if(iter.ge.5)umid=(udown+uup)/2.d0
      iter=iter+1
      if(range.le..01)then
         uhat(ncart)=umid
         if(ncart.gt.1)then
            ncartm1=ncart-1
            do 4 i=1,ncartm1
   4           uhat(i)=uhat(i)+umid
            endif
         return
         endif
      call heval(ncart,prdsm,umid,hmid,1)
c
c       bisect.
c
      if(abs(hmid).lt.1.d-4)then
         uhat(ncart)=umid
         if(ncart.gt.1)then
            ncartm1=ncart-1
            do 5 i=1,ncartm1
   5           uhat(i)=uhat(i)+umid
            endif
         return
         endif
      if(hmid.lt.0.)then
         uup=umid
         hup=hmid
         goto 3
         endif
      if(hmid.gt.0.)then
         udown=umid
         hdown=hmid
         goto 3
         endif
      end
c
c
      subroutine heval(ncart,prdsm,u,h,iresid)
c
c       this subroutine computes the residual for total mileage.
c
      parameter(ncars=10,nccharts=2,nhouses=11,nobss=26000,nobsss=
     & nobss*2,ngrids=10,ngridp1s=ngrids+1)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension ivrec(3,2),vort(3),vrec(3,2)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      if((iobs.eq.500).and.(abs(u+.663).lt..01))then
         fred=5.
         endif
      ncarm=ncart
      if(ncarm.gt.3)ncarm=3
      ngrid=ngridp1-1
c
c       adjust vor.
c
      vort(1)=vor(1)+u
      if(ncarm.gt.1)then
         do 4 i=2,ncarm
   4        vort(i)=vor(i)-vor(i-1)
         endif
c
c       find boundaries.
c
      ibdflg=0
      do 2 i=1,ncarm
         if(vort(i).le.vgrid(i,1))then
            vrec(i,1)=vgrid(i,1)
            vrec(i,2)=vgrid(i,2)
            ivrec(i,1)=0
            ivrec(i,2)=1
            ibdflg=1
            goto 2
            endif
         do 3 j=2,ngridp1
            if(vort(i).le.vgrid(i,j))then
               jm1=j-1
               vrec(i,1)=vgrid(i,jm1)
               vrec(i,2)=vgrid(i,j)
               ivrec(i,1)=jm1
               ivrec(i,2)=j
               goto 2
               endif
   3        continue
         vrec(i,1)=vgrid(i,ngrid)
         vrec(i,2)=vgrid(i,ngridp1)
         ivrec(i,1)=ngridp1
         ivrec(i,2)=ngridp1+1
         ibdflg=1
   2     continue
c
c       interpolate.
c
      call interp(ncarm,vort,vrec,ivrec,ibdflg,h)
      h=h+prdsm
c
c       construct residual.
c
      if(iresid.eq.1)h=log(dble(summiles(iobs)))-h
      if((abs(log(dble(summiles(iobs)))-prdsm).gt.4.).and.
     & (abs(h).lt..01))then
         fred=4.
         endif
      return
      end
c
c
      subroutine hsimul(parm)
c
c       this subroutine simulates the h function.  for families with 
c       two cars, it reports results over a grid of the values of the 
c       two cars.  for families with three or more cars, it reports 
c       results over a grid of the values for the two best cars and 
c       the average value of the third car.
c
      parameter(ncars=10,ncarm1s=ncars-1,ncchars=80,nccharts=2,
     & ngrids=10,ngridp1s=ngrids+1,nhouses=11,nobss=26000,
     & nobsss=nobss*2,npolys=2,
     & ncoefs=ncchars+13+(npolys)*3+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 amount(3)
      real et,hchar,propmil,rand2,summiles,ut
      dimension avgrid(2,21),av3(21,21,3,3),parm(ncoefs),u(ncars),
     & usum(5)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      data amount/'1 car','2 cars','>2 cars'/
c
c       initialize.
c
      prdsm=0.d0
      u=0.d0
      iseed=1
      ut=rand2(iseed)
      iseed=0
      do 6 i=1,3
   6     usum(i)=0.d0
      usum(4)=1.d20
      usum(5)=-1.d20
      call parset1(parm)
      call parset2
      call shareinit
      do 11 i=1,21
         do 11 j=1,21
            do 11 k=1,3
               do 11 l=1,3
  11              av3(i,j,k,l)=0.d0
      do 13 i=1,2
         if(i.eq.1)then
            avgrid(i,1)=-3.d0
            delgrid=6.d0/20.d0
            endif
         if(i.eq.2)then
            avgrid(i,1)=-5.d0
            delgrid=5.d0/20.d0
            endif
         do 14 j=2,21
            jm1=j-1
  14        avgrid(i,j)=avgrid(i,jm1)+delgrid
  13     continue
c
c       process each observation.
c
      do 2 i=1,nobs
         if(((i/1000)*1000).eq.i)write(6,105)i
 105     format(1x,'i = ',i5)
         ncart=ncar(i)
         do 3 j=1,2
            do 4 k=1,2
               if(k.eq.1)then
                  do 5 l=1,ncart
                     ut=rand2(iseed)
                     usum(1)=usum(1)+1.d0
                     dut=dble(ut)
                     usum(2)=usum(2)+dut
                     usum(3)=usum(3)+(dut*dut)
                     if(usum(4).gt.dut)usum(4)=dut
                     if(usum(5).lt.dut)usum(5)=dut
                     iseed=0
                     call utrunc(ut)
                     call mdnris(ut,et,ier)
   5                 u(l)=et*sigu
                  endif
               if(k.eq.2)then
                  do 7 l=1,ncart
   7                 u(l)=-1.d0*u(l)
                  endif
c
c       compute h.
c
               call sharep(u,ncart,nu,propmiles)
               umax=0.d0
               call heval(ncart,prdsm,umax,h,0)
c
c       update moments.
c       output when the family has only one car.
c
               if(ncart.eq.1)then
                  if(vor(1).le.avgrid(1,1))then
                     write(6,100)i,j,k,vor(1)
                     goto 4
                     endif
                  do 17 l=2,21
                     if(vor(1).le.avgrid(1,l))then
                        av3(l,1,1,1)=av3(l,1,1,1)+1.d0
                        av3(l,1,1,2)=av3(l,1,1,2)+h
                        goto 4
                        endif
  17                 continue
                  write(6,100)i,j,k,vor(1)
 100              format(1x,'vor(1) out of range for i,j,k = ',i6,
     &             2(2x,i1),2x,g15.8)
                  endif
c
c       update when the family has more than one car.
c
               if(ncart.ge.2)then
                  vort=vor(2)-vor(1)
                  if(vor(1).le.avgrid(1,1))then
                     write(6,100)i,j,k,vor(1)
                     goto 4
                     endif
                  do 8 l=2,21
                     if(vor(1).le.avgrid(1,l))then
                        if(vort.le.avgrid(2,1))then
                           write(6,103)i,j,k,vort
                           goto 4
                           endif
                        do 9 m=2,21
                           if(vort.le.avgrid(2,m))then
                              if(ncart.eq.2)then
                                 av3(l,m,2,1)=av3(l,m,2,1)+1.d0
                                 av3(l,m,2,2)=av3(l,m,2,2)+h
                                 endif
                              if(ncart.ge.3)then
                                 av3t=0.d0
                                 do 10 n=3,ncart
  10                                av3t=av3t+(vor(n)-vor(2))
                                 av3t=av3t/dble(float(ncart-2))
                                 av3(l,m,3,1)=av3(l,m,3,1)+1.d0
                                 av3(l,m,3,2)=av3(l,m,3,2)+h
                                 av3(l,m,3,3)=av3(l,m,3,3)+av3t
                                 endif
                              goto 4
                              endif
   9                       continue
                        write(6,103)i,j,k,vort
 103                    format(1x,'bad vort for i,j,k = ',i6,
     &                   2(2x,i1),g15.8)
                        endif
   8                 continue
                  write(6,104)i,j,k,vor(1)
 104              format(1x,'bad vor(1) for i,j,k = ',i6,2(2x,i1),g15.8)
                  endif
   4           continue
   3        continue
   2     continue
c
c      adjust and output moments.
c
      usum(2)=usum(2)/usum(1)
      usum(3)=((usum(3)/usum(1))-(usum(2)*usum(2)))**.5d0
      write(6,106)(usum(i),i=1,5)
 106  format(1x,'moments of uniform errors:',/,1x,'# obs: ',f8.0,/,1x,
     & 'mean: ',g15.8,/,1x,'std dev: ',g15.8,/,'minimum: ',g15.8,/,1x,
     & 'maximum: ',g15.8)
      do 16 i=1,3
         write(6,102)
 102     format(1x,50('='))
         write(6,101)amount(i)
 101     format(1x,'results for families with ',a8)
         if(i.eq.1)write(6,109)
 109     format(1x,'vor(1)',14x,'# obs',3x,'h')
         if(i.eq.2)write(6,108)
 108     format(1x,'vor(1)',4x,'dvor(2)',3x,'# obs',3x,'h')
         if(i.eq.3)write(6,110)
 110     format(1x,'vor(1)',4x,'dvor(2)',3x,'# obs',3x,'h',9x,
     &    'inf mean')
         if(i.eq.1)then
            ib=1
            ie=1
            endif
         if(i.gt.1)then
            ib=2
            ie=21
            endif
         do 12 j=2,21
            jm1=j-1
            avgrid1a=(avgrid(1,jm1)+avgrid(1,j))/2.d0
            do 12 k=ib,ie
               if(av3(j,k,i,1).gt.0.)then
                  if(i.gt.1)then
                     km1=k-1
                     avgrid2a=(avgrid(2,km1)+avgrid(2,k))/2.d0
                     endif
                  av3(j,k,i,2)=av3(j,k,i,2)/av3(j,k,i,1)
                  if(i.eq.1)write(6,111)avgrid1a,(av3(j,k,i,l),l=1,2)
 111              format(1x,f8.3,12x,f6.0,2x,f8.3)
                  if(i.gt.1)then
                     if(i.eq.3)av3(j,k,i,3)=av3(j,k,i,3)/av3(j,k,i,1)
                     write(6,107)avgrid1a,avgrid2a,(av3(j,k,i,l),l=1,i)
 107                 format(1x,f8.3,2x,f8.3,2x,f6.0,2(2x,f8.3))
                     endif
                  endif
  12           continue
  16     continue
      return
      end
c
c  
      subroutine initia(method,parm,nparm)
c
c       this subroutine gets parameters and data.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      dimension parm(ncoefs)
      call parget(method,parm,nparm)
      if(method.ne.14)call datget
      return
      end
c
c
      subroutine interp(ncarm,v,vrec,ivrec,ibdflg,h)
c
c       this subroutine interpolates in up to three dimensions.
c
      parameter(nobss=26000,ncars=10,ngrids=10,ngridp1s=ngrids+1)
      implicit real*8(a-h,o-z)
      dimension aint3t(2),dist(2),ivrec(3,2),slope3t(2),v(3),vgt(2),
     & vrec(3,2),weight(3,2)
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
c
c       check for boundary problems.
c
      if(ibdflg.eq.1)then
c
c       compute h if just one car.
c
         if(ncarm.eq.1)then
            if(ivrec(1,2).eq.1)h=aint1(1)+(v(1)*slope1(1))
            if(ivrec(1,1).eq.ngridp1)h=aint1(2)+(v(1)*slope1(2))
            return
            endif
c
c       compute h if two cars.
c
         if(ncarm.eq.2)then
            ngrid=ngridp1-1
c
c       compute h if at a corner.
c
            if((ivrec(1,2).eq.1).and.(ivrec(2,2).eq.1))then
               h=aint2(1)+(slope2(1,1)*v(1))
               h=h+(slope2(1,2)*(v(2)-vgrid(2,1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,2).eq.1))then
               h=aint2(2)+(slope2(2,1)*v(1))
               h=h+(slope2(2,2)*(v(2)-vgrid(2,1)))
               return
               endif
            if((ivrec(1,2).eq.1).and.(ivrec(2,1).eq.ngridp1))then
               h=aint2(3)+(slope2(3,1)*v(1))
               h=h+(slope2(3,2)*(v(2)-vgrid(2,ngridp1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,1).eq.ngridp1))then
               h=aint2(4)+(slope2(4,1)*v(1))
               h=h+(slope2(4,2)*(v(2)-vgrid(2,ngridp1)))
               return
               endif
c
c       compute h if at a boundary.
c
            if((ivrec(1,2).eq.1).or.(ivrec(1,1).eq.ngridp1))then
               dist(1)=v(2)-vrec(2,1)
               dist(2)=vrec(2,2)-v(2)
               sum=dist(1)+dist(2)
               weight(2,1)=dist(2)/sum
               weight(2,2)=dist(1)/sum
               do 6 i=1,2
                  if(ivrec(1,2).eq.1)it=i
                  if(ivrec(1,1).eq.ngridp1)it=ngridp1-2+i
                  vgt(i)=0.d0
                  do 6 j=1,2
   6                 vgt(i)=vgt(i)+(weight(2,j)*vgval2(it,ivrec(2,j)))
               if(ivrec(1,2).eq.1)then
                  slope2t=(vgt(2)-vgt(1))/(vgrid(1,2)-vgrid(1,1))
                  aint2t=vgt(1)-(slope2t*vgrid(1,1))
                  endif
               if(ivrec(1,1).eq.ngridp1)then
                  slope2t=(vgt(2)-vgt(1))/(vgrid(1,ngridp1)-
     &             vgrid(1,ngrid))
                  aint2t=vgt(2)-(slope2t*vgrid(1,ngridp1))
                  endif
               h=aint2t+(v(1)*slope2t)
               return
               endif
            if((ivrec(2,2).eq.1).or.(ivrec(2,1).eq.ngridp1))then
               dist(1)=v(1)-vrec(1,1)
               dist(2)=vrec(1,2)-v(1)
               sum=dist(1)+dist(2)
               weight(1,1)=dist(2)/sum
               weight(1,2)=dist(1)/sum
               do 7 i=1,2
                  if(ivrec(2,2).eq.1)it=i
                  if(ivrec(2,1).eq.ngridp1)it=ngridp1-2+i
                  vgt(i)=0.d0
                  do 7 j=1,2
   7                 vgt(i)=vgt(i)+(weight(1,j)*vgval2(ivrec(1,j),it))
               if(ivrec(2,2).eq.1)then
                  slope2t=(vgt(2)-vgt(1))/(vgrid(2,2)-vgrid(2,1))
                  aint2t=vgt(1)-(slope2t*vgrid(2,1))
                  endif
               if(ivrec(2,1).eq.ngridp1)then
                  slope2t=(vgt(2)-vgt(1))/(vgrid(2,ngridp1)-
     &             vgrid(2,ngrid))
                  aint2t=vgt(2)-(slope2t*vgrid(2,ngridp1))
                  endif
               h=aint2t+(v(2)*slope2t)
               return
               endif
            endif
c
c       compute h if three cars.
c
         if(ncarm.eq.3)then
            ngrid=ngridp1-1
c
c       compute h if at a corner.
c
            if((ivrec(1,2).eq.1).and.(ivrec(2,2).eq.1).and.
     &       (ivrec(3,2).eq.1))then
               h=vgval3(1,1,1)
               do 8 i=1,3
   8              h=h+(slope3(1,i)*(v(i)-vgrid(i,1)))
               return
               endif
            if((ivrec(1,2).eq.1).and.(ivrec(2,2).eq.1).and.
     &       (ivrec(3,1).eq.ngridp1))then
               h=vgval3(1,1,ngridp1)
               h=h+(slope3(2,1)*(v(1)-vgrid(1,1)))
               h=h+(slope3(2,2)*(v(2)-vgrid(2,1)))
               h=h+(slope3(2,3)*(v(3)-vgrid(3,ngridp1)))
               return
               endif
            if((ivrec(1,2).eq.1).and.(ivrec(2,1).eq.ngridp1).and.
     &       (ivrec(3,2).eq.1))then
               h=vgval3(1,ngridp1,1)
               h=h+(slope3(3,1)*(v(1)-vgrid(1,1)))
               h=h+(slope3(3,2)*(v(2)-vgrid(2,ngridp1)))
               h=h+(slope3(3,3)*(v(3)-vgrid(3,1)))
               return
               endif
            if((ivrec(1,2).eq.1).and.(ivrec(2,1).eq.ngridp1).and.
     &       (ivrec(3,1).eq.ngridp1))then
               h=vgval3(1,ngridp1,ngridp1)
               h=h+(slope3(4,1)*(v(1)-vgrid(1,1)))
               h=h+(slope3(4,2)*(v(2)-vgrid(2,ngridp1)))
               h=h+(slope3(4,3)*(v(3)-vgrid(3,ngridp1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,2).eq.1).and.
     &       (ivrec(3,2).eq.1))then
               h=vgval3(ngridp1,1,1)
               h=h+(slope3(5,1)*(v(1)-vgrid(1,ngridp1)))
               h=h+(slope3(5,2)*(v(2)-vgrid(2,1)))
               h=h+(slope3(5,3)*(v(3)-vgrid(3,1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,2).eq.1).and.
     &       (ivrec(3,1).eq.ngridp1))then
               h=vgval3(ngridp1,1,ngridp1)
               h=h+(slope3(6,1)*(v(1)-vgrid(1,ngridp1)))
               h=h+(slope3(6,2)*(v(2)-vgrid(2,1)))
               h=h+(slope3(6,3)*(v(3)-vgrid(3,ngridp1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,1).eq.ngridp1).and.
     &       (ivrec(3,2).eq.1))then
               h=vgval3(ngridp1,ngridp1,1)
               h=h+(slope3(7,1)*(v(1)-vgrid(1,ngridp1)))
               h=h+(slope3(7,2)*(v(2)-vgrid(2,ngridp1)))
               h=h+(slope3(7,3)*(v(3)-vgrid(3,1)))
               return
               endif
            if((ivrec(1,1).eq.ngridp1).and.(ivrec(2,1).eq.ngridp1).and.
     &       (ivrec(3,1).eq.ngridp1))then
               h=vgval3(ngridp1,ngridp1,ngridp1)
               h=h+(slope3(8,1)*(v(1)-vgrid(1,ngridp1)))
               h=h+(slope3(8,2)*(v(2)-vgrid(2,ngridp1)))
               h=h+(slope3(8,3)*(v(3)-vgrid(3,ngridp1)))
               return
               endif
c
c       compute h if at a line.  
c
            if(((ivrec(1,2).eq.1).or.(ivrec(1,1).eq.ngridp1)).and.
     &       ((ivrec(2,2).eq.1).or.(ivrec(2,1).eq.ngridp1)))then
               dist(1)=v(3)-vrec(3,1)
               dist(2)=vrec(3,2)-v(3)
               sum=dist(1)+dist(2)
               weight(3,1)=dist(2)/sum
               weight(3,2)=dist(1)/sum
               if(ivrec(1,2).eq.1)ivgv1=1
               if(ivrec(1,1).eq.ngridp1)ivgv1=ngridp1
               if(ivrec(2,2).eq.1)ivgv2=1
               if(ivrec(2,1).eq.ngridp1)ivgv2=ngridp1
               h=0.d0
               do 9 i=1,2
                  do 10 j=1,2
                     vgt(j)=0.d0
                     if(i.eq.1)then
                        if(ivrec(1,2).eq.1)ivg1=j
                        if(ivrec(1,1).eq.ngridp1)ivg1=ngrid-1+j
                        if(ivrec(2,2).eq.1)ivg2=1
                        if(ivrec(2,1).eq.ngridp1)ivg2=ngridp1
                        endif
                     if(i.eq.2)then
                        if(ivrec(1,2).eq.1)ivg1=1
                        if(ivrec(1,1).eq.ngridp1)ivg1=ngridp1
                        if(ivrec(2,2).eq.1)ivg2=j
                        if(ivrec(2,1).eq.ngridp1)ivg2=ngrid-1+j
                        endif
                     do 24 k=1,2
  24                    vgt(j)=vgt(j)+(weight(3,k)*
     &                   vgval3(ivg1,ivg2,ivrec(3,k)))
  10                 continue
                  if(ivrec(i,2).eq.1)iv2=2
                  if(ivrec(i,1).eq.ngridp1)iv2=ngridp1
                  iv1=iv2-1
                  slope3t(i)=(vgt(2)-vgt(1))/(vgrid(i,iv2)-
     &             vgrid(i,iv1))
   9              h=h+(weight(3,i)*vgval3(ivgv1,ivgv2,ivrec(3,i)))
               h=h+(slope3t(1)*(v(1)-vgrid(1,ivgv1)))
               h=h+(slope3t(2)*(v(2)-vgrid(2,ivgv2)))
               return
               endif
            if(((ivrec(1,2).eq.1).or.(ivrec(1,1).eq.ngridp1)).and.
     &       ((ivrec(3,2).eq.1).or.(ivrec(3,1).eq.ngridp1)))then
               dist(1)=v(2)-vrec(2,1)
               dist(2)=vrec(2,2)-v(2)
               sum=dist(1)+dist(2)
               weight(2,1)=dist(2)/sum
               weight(2,2)=dist(1)/sum
               if(ivrec(1,2).eq.1)ivgv1=1
               if(ivrec(1,1).eq.ngridp1)ivgv1=ngridp1
               if(ivrec(3,2).eq.1)ivgv3=1
               if(ivrec(3,1).eq.ngridp1)ivgv3=ngridp1
               h=0.d0
               i13=-1
               do 11 i=1,2
                  i13=i13+2
                  do 12 j=1,2
                     vgt(j)=0.d0
                     if(i.eq.1)then
                        if(ivrec(1,2).eq.1)ivg1=j
                        if(ivrec(1,1).eq.ngridp1)ivg1=ngrid-1+j
                        if(ivrec(3,2).eq.1)ivg3=1
                        if(ivrec(3,1).eq.ngridp1)ivg3=ngridp1
                        endif
                     if(i.eq.2)then
                        if(ivrec(1,2).eq.1)ivg1=1
                        if(ivrec(1,1).eq.ngridp1)ivg1=ngridp1
                        if(ivrec(3,2).eq.1)ivg3=j
                        if(ivrec(3,1).eq.ngridp1)ivg3=ngrid-1+j
                        endif
                     do 25 k=1,2
  25                    vgt(j)=vgt(j)+(weight(2,k)*
     &                   vgval3(ivg1,ivrec(2,k),ivg3))
  12                 continue
                  if(ivrec(i13,2).eq.1)iv2=2
                  if(ivrec(i13,1).eq.ngridp1)iv2=ngridp1
                  iv1=iv2-1
                  slope3t(i)=(vgt(2)-vgt(1))/(vgrid(i13,iv2)-
     &             vgrid(i13,iv1))
  11              h=h+(weight(2,i)*vgval3(ivgv1,ivrec(2,i),ivgv3))
               h=h+(slope3t(1)*(v(1)-vgrid(1,ivgv1)))
               h=h+(slope3t(2)*(v(2)-vgrid(3,ivgv3)))
               return
               endif
            if(((ivrec(2,2).eq.1).or.(ivrec(2,1).eq.ngridp1)).and.
     &       ((ivrec(3,2).eq.1).or.(ivrec(3,1).eq.ngridp1)))then
               dist(1)=v(1)-vrec(1,1)
               dist(2)=vrec(1,2)-v(1)
               sum=dist(1)+dist(2)
               weight(1,1)=dist(2)/sum
               weight(1,2)=dist(1)/sum
               if(ivrec(2,2).eq.1)ivgv2=1
               if(ivrec(2,1).eq.ngridp1)ivgv2=ngridp1
               if(ivrec(3,2).eq.1)ivgv3=1
               if(ivrec(3,1).eq.ngridp1)ivgv3=ngridp1
               h=0.d0
               i23=1
               do 13 i=1,2
                  i23=i23+1
                  do 14 j=1,2
                     vgt(j)=0.d0
                     if(i.eq.1)then
                        if(ivrec(2,2).eq.1)ivg2=j
                        if(ivrec(2,1).eq.ngridp1)ivg2=ngrid-1+j
                        if(ivrec(3,2).eq.1)ivg3=1
                        if(ivrec(3,2).eq.ngridp1)ivg3=ngridp1
                        endif
                     if(i.eq.2)then
                        if(ivrec(2,2).eq.1)ivg2=1
                        if(ivrec(2,1).eq.ngridp1)ivg2=ngridp1
                        if(ivrec(3,2).eq.1)ivg3=j
                        if(ivrec(3,1).eq.ngridp1)ivg3=ngrid-1+j
                        endif
                     do 26 k=1,2
  26                    vgt(j)=vgt(j)+(weight(1,k)*
     &                   vgval3(ivrec(1,k),ivg2,ivg3))
  14                 continue
                  if(ivrec(i23,2).eq.1)iv2=2
                  if(ivrec(i23,1).eq.ngridp1)iv2=ngridp1
                  iv1=iv2-1
                  slope3t(i)=(vgt(2)-vgt(1))/(vgrid(i23,iv2)-
     &             vgrid(i23,iv1))
  13              h=h+(weight(1,i)*vgval3(ivrec(1,i),ivgv2,ivgv3))
               h=h+(slope3t(1)*(v(2)-vgrid(2,ivgv2)))
               h=h+(slope3t(2)*(v(3)-vgrid(3,ivgv3)))
               return
               endif
c
c       compute h if at a plane.  
c
            if((ivrec(1,2).eq.1).or.(ivrec(1,1).eq.ngridp1))then
               do 15 i=2,3
                  dist(1)=v(i)-vrec(i,1)
                  dist(2)=vrec(i,2)-v(i)
                  weight(i,1)=dist(2)
  15              weight(i,2)=dist(1)
               if(ivrec(1,2).eq.1)then
                  i1=0
                  j2=2
                  endif
               if(ivrec(1,1).eq.ngridp1)then
                  i1=ngrid-1
                  j2=ngridp1
                  endif
               j1=j2-1
               do 16 i=1,2
                  i1=i1+1
                  vgt(i)=0.d0
                  tw=0.d0
                  do 17 j=1,2
                     do 17 k=1,2
                        twt=weight(2,j)*weight(3,k)
                        vgt(i)=vgt(i)+(twt*
     &                   vgval3(i1,ivrec(2,j),ivrec(3,k)))
  17                    tw=tw+twt
  16              vgt(i)=vgt(i)/tw
               slope3t(1)=(vgt(2)-vgt(1))/(vgrid(1,j2)-vgrid(1,j1))
               aint3t(1)=vgt(1)-(slope3t(1)*vgrid(1,j1))
               h=aint3t(1)+(slope3t(1)*v(1))
               return
               endif
            if((ivrec(2,2).eq.1).or.(ivrec(2,1).eq.ngridp1))then
               it=-1
               do 18 i=1,2
                  it=it+2
                  dist(1)=v(it)-vrec(it,1)
                  dist(2)=vrec(it,2)-v(it)
                  weight(it,1)=dist(2)
  18              weight(it,2)=dist(1)
               if(ivrec(2,2).eq.1)then
                  i1=0
                  j2=2
                  endif
               if(ivrec(2,1).eq.ngridp1)then
                  i1=ngrid-1
                  j2=ngridp1
                  endif
               j1=j2-1
               do 19 i=1,2
                  i1=i1+1
                  vgt(i)=0.d0
                  tw=0.d0
                  do 20 j=1,2
                     do 20 k=1,2
                        twt=weight(1,j)*weight(3,k)
                        vgt(i)=vgt(i)+(twt*
     &                   vgval3(ivrec(1,j),i1,ivrec(3,k)))
  20                    tw=tw+twt
  19              vgt(i)=vgt(i)/tw
               slope3t(1)=(vgt(2)-vgt(1))/(vgrid(2,j2)-vgrid(2,j1))
               aint3t(1)=vgt(2)-(slope3t(1)*vgrid(2,j2))
               h=aint3t(1)+(slope3t(1)*v(2))
               return
               endif
            if((ivrec(3,2).eq.1).or.(ivrec(3,1).eq.ngridp1))then
               do 21 i=1,2
                  dist(1)=v(i)-vrec(i,1)
                  dist(2)=vrec(i,2)-v(i)
                  weight(i,1)=dist(2)
  21              weight(i,2)=dist(1)
               if(ivrec(3,2).eq.1)then
                  i1=0
                  j2=2
                  endif
               if(ivrec(3,1).eq.ngridp1)then
                  i1=ngrid-1
                  j2=ngridp1
                  endif
               j1=j2-1
               do 22 i=1,2
                  i1=i1+1
                  vgt(i)=0.d0
                  tw=0.d0
                  do 23 j=1,2
                     do 23 k=1,2
                        twt=weight(1,j)*weight(2,k)
                        vgt(i)=vgt(i)+(twt*
     &                   vgval3(ivrec(1,j),ivrec(2,k),i1))
  23                    tw=tw+twt
  22              vgt(i)=vgt(i)/tw
               slope3t(1)=(vgt(2)-vgt(1))/(vgrid(3,j2)-vgrid(3,j1))
               aint3t(1)=vgt(2)-(slope3t(1)*vgrid(3,j2))
               h=aint3t(1)+(slope3t(1)*v(3))
               return
               endif
            endif
         endif
c
c       compute weights.
c
      do 2 i=1,ncarm
         dist(1)=v(i)-vrec(i,1)
         dist(2)=vrec(i,2)-v(i)
         sum=dist(1)+dist(2)
         weight(i,1)=dist(2)/sum
         weight(i,2)=dist(1)/sum
   2     continue
c
c       take weighted average.
c
      h=0.d0
      tw=0.d0
      if(ncarm.eq.1)then
         do 3 i=1,2
            h=h+(weight(1,i)*vgval1(ivrec(1,i)))
   3        tw=tw+weight(1,i)
         endif
      if(ncarm.eq.2)then
         do 4 i=1,2
            do 4 j=1,2
               twt=weight(1,i)*weight(2,j)
               h=h+(twt*vgval2(ivrec(1,i),ivrec(2,j)))
   4           tw=tw+twt
         endif
      if(ncarm.eq.3)then
         do 5 i=1,2
            do 5 j=1,2
               do 5 k=1,2
                  twt=weight(1,i)*weight(2,j)*weight(3,k)
                  h=h+(twt*vgval3(ivrec(1,i),ivrec(2,j),ivrec(3,k)))
   5              tw=tw+twt
         endif
      h=h/tw
      return
      end
c
c
      subroutine kernel(prdsm1,prdsm2,bandprd,akern)
c
c       this subroutine is the kernel function for measuring household 
c       demographic proximity.
c
      implicit real*8(a-h,o-z)
      arg=abs(prdsm1-prdsm2)/bandprd
      if(arg.gt.4.)then
         akern=0.d0
         return
         endif
      akern=exp((-0.5d0)*arg*arg)/bandprd
      return
      end
c
c
      subroutine lanormd(x,val)
c
c       this subroutine evaluates the standard normal density.
c
      implicit real*8 (a-h,o-z)
      data alsqpii/-0.918938534/
      val=alsqpii-(x*x/2.d0)
      return
      end
c
c
      subroutine likely(parm,nparm,f,ier)
c
c       this subroutine is the log likelihood function.
c
      parameter(ncars=10,ncarm1s=ncars-1,nobss=26000,nobsss=nobss*2,
     & ncchars=80,nccharts=2,nhouses=11,npolys=2,ncoefs=ncchars+13+
     & (npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension parm(ncoefs)
      common/best/fbest(3)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
c     common/icoc/ico
      common/wdiagn/iwrite
c     ico=ico+1
c     write(6,444)ico
c444  format(1x,'ico = ',i5)
      call parset1(parm)
      call parset2
      call shareinit
      f=0.d0
c     open(unit=9,file='likconts.d')
      do 2 i=1,nobs
         if(i.eq.13654)then
            fred=1.
            endif
         call likobs(i,ft)
         f=f+ft
         write(6,444)i,f,ft
         if(iwrite.eq.1)write(6,444)i,f,ft
 444     format(1x,i6,2x,g15.8,2x,g15.8)
   2     continue
      stop
      if(f.gt.fbest(3))then
         if(f.gt.fbest(2))then
            fbest(3)=fbest(2)
            if(f.gt.fbest(1))then
               fbest(2)=fbest(1)
               fbest(1)=f
               goto 3
               endif
            fbest(2)=f
            goto 3
            endif
         fbest(3)=f
         endif
   3  write(6,100)f,(fbest(i),i=1,3)
 100  format(1x,'f = ',g15.8,1x,'fbest = ',3(1x,g15.8))
      return
      end
c
c
      subroutine likelypass(parm,nparm,objt)
c
c       this subroutine is just a pass-through for the numerical 
c       methods simplex method.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      dimension parm(ncoefs)
      call likely(parm,nparm,objt,ier)
      objt=(-1.d0)*objt
      return
      end
c
c
      subroutine likobs(iobt,f)
c
c       this subroutine is the log likelihood contribution for 
c       household iobs.
c
      parameter(ncars=10,ncarm1s=ncars-1,nobss=26000,nobsss=nobss*2,
     & ncchars=80,nccharts=2,nhouses=11,npolys=2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension uhat(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      imshr=2
      iobs=iobt
      ncart=ncar(iobs)
      if(ishare.eq.0)then
         ncartm1=ncart-1
         do 3 i=1,ncart
   3        uhat(i)=0.d0
         call share(uhat,ncartm1,objt)
         endif
      if((ishare.eq.1).or.(ishare.eq.2))then
         if(imshr.eq.2)call uhatconst2(ncart,uhat,iconv)
         if((imshr.eq.1).or.(iconv.eq.0))call uhatconst1(ncart,uhat)
         endif
c     if(itotmil.eq.0)uhat(ncart)=0.d0
      if(itotmil.eq.0)call sharenorm(ncart,uhat)
      if(itotmil.eq.1)call hconst(ncart,uhat)
      if(ishare.eq.0)then
         arg=uhat(ncart)/ncart
         arg=arg/sigu
         call lanormd(arg,f)
         f=(f-log(sigu))*ncart
         endif
      if(ishare.eq.1)then
         f=0.d0
         do 2 i=1,ncart
            arg=uhat(i)/sigu
            call lanormd(arg,ft)
            f=f+ft
   2        continue
         f=f-(ncart*log(sigu))
         endif
      if(ishare.eq.2)then
         arg=0.d0
         do 4 i=1,ncart
   4        arg=arg+uhat(i)
         arg=arg/ncart
         arg=arg/sigu
         call lanormd(arg,f)
         f=(f-log(sigu))*ncart
         endif
      return
      end
c
c
      subroutine linv3f (a,b,ijob,n,ia,d1,d2,wkarea,ier)                
c
c   imsl routine name   - linv3f                                        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
c   computer            - prim77/single                                 
c                                                                       
c   latest revision     - june 1, 1982                                  
c                                                                       
c   purpose             - in place inverse, equation solution, and/or   
c                           determinant evaluation - full storage mode  
c                                                                       
c   usage               - call linv3f (a,b,ijob,n,ia,d1,d2,wkarea,ier)  
c                                                                       
c   arguments    a      - input/output matrix of dimension n by n. see  
c                           parameter ijob.                             
c                b      - input/output vector of length n when ijob =   
c                           2 or 3. otherwise, b is not used.           
c                         on input, b contains the right hand side of   
c                           of the equation ax = b.                     
c                         on output, the solution x replaces b.         
c                ijob   - input option parameter. ijob = i implies:     
c                           i = 1, invert matrix a. a is replaced by    
c                             its inverse.                              
c                           i = 2, solve the equation ax = b. a is      
c                             replaced by the lu decomposition of a     
c                             rowwise permutation of a, where u is      
c                             upper triangular and l is lower           
c                             triangular with unit diagonal.            
c                             the unit diagonal of l is not stored.     
c                           i = 3, solve ax = b and invert matrix a.    
c                             a is replaced by its inverse.             
c                           i = 4, compute the determinant of a.        
c                             a is replaced by the lu decomposition     
c                             of a rowwise permutation of a.            
c                n      - order of a. (input)                           
c                ia     - row dimension of matrix a exactly as          
c                           specified in the dimension statement in the 
c                           calling program. (input)                    
c                d1     - input/output. if the d1 and d2 components     
c                d2         of determinant(a) = d1*2**d2 are desired,   
c                           input d1.ge.0. otherwise, input d1.lt.0.    
c                           d2 is never input.                          
c                wkarea - work area of length at least 2*n for ijob=1   
c                           or ijob=3.                                  
c                         work area of length at least n for ijob=2     
c                           or ijob=4.                                  
c                ier    - error parameter. (output)                     
c                         warning with fix                              
c                           ier = 65 indicates that ijob was less than  
c                             1 or greater than 4. ijob is assumed to   
c                             be 4.                                     
c                         terminal error                                
c                           ier = 130 indicates that matrix a is        
c                             algorithmically singular. (see the        
c                             chapter l prelude).                       
c                                                                       
c   precision/hardware  - single and double/h32                         
c                       - single/h36,h48,h60                            
c                                                                       
c   reqd. imsl routines - ludatn,luelmn
c                                                                       
c   notation            - information on special notation and           
c                           conventions is available in the manual      
c                           introduction or through imsl routine uhelp  
c                                                                       
c   copyright           - 1978 by imsl, inc. all rights reserved.       
c                                                                       
c   warranty            - imsl warrants only that imsl testing has been 
c                           applied to this code. no other warranty,    
c                           expressed or implied, is applicable.        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
c                                                                       
      implicit real*8 (a-h,o-z)
c     implicit real (a-h,o-z)
      real*8             a(ia,n),b(n),wkarea(400)                       
c     real*4             a(ia,n),b(n),wkarea(400)                       
      data               zero/0.d0/,one/1.d0/                           
c                                  first executable statement           
c                                  lu decomposition of a                
      call ludatn (a,ia,n,a,ia,0,c1,c2,wkarea,wkarea,wa,ier)            
      if (d1 .lt. zero .and. ijob .ge. 1 .and. ijob .lt. 4) go to 5     
      d1 = c1                                                           
      d2 = c2                                                           
    5 if (ier .ge. 128) go to 60                                        
      if (ijob .le. 0 .or. ijob .gt. 4) go to 55                        
c                                  solve ax = b                         
      if (ijob .eq. 2 .or . ijob .eq. 3) call luelmn (a,ia,n,b,wkarea,b)
      if (ijob .ne. 1 .and. ijob .ne. 3) go to 9005                     
c                                  matrix inversion                     
      a(n,n) = one/a(n,n)                                               
      nm1 = n-1                                                         
      if (nm1 .lt. 1) go to 9005                                        
      do 40 ii=1,nm1                                                    
         l = n-ii                                                       
         m = l+1                                                        
         do 15 i=m,n                                                    
            sum = zero                                                  
            do 10 k=m,n                                                 
               sum = sum-a(i,k)*a(k,l)                                  
   10       continue                                                    
            wkarea(n+i) = sum                                           
   15    continue                                                       
         do 20 i=m,n                                                    
            a(i,l) = wkarea(n+i)                                        
   20    continue                                                       
         do 30 j=l,n                                                    
            sum = zero                                                  
            if (j .eq. l) sum = one                                     
            do 25 k=m,n                                                 
               sum = sum-a(l,k)*a(k,j)                                  
   25       continue                                                    
            wkarea(n+j) = sum/a(l,l)                                    
   30    continue                                                       
         do 35 j=l,n                                                    
            a(l,j) = wkarea(n+j)                                        
   35    continue                                                       
   40 continue                                                          
c                                  permute columns of a inverse         
      do 50 i=1,n                                                       
         j = n-i+1                                                      
         jp = wkarea(j)                                                 
         if (j .eq. jp) go to 50                                        
         do 45 k=1,n                                                    
            c = a(k,jp)                                                 
            a(k,jp) = a(k,j)                                            
            a(k,j) = c                                                  
   45    continue                                                       
   50 continue                                                          
      go to 9005                                                        
   55 continue                                                          
c                                  warning with fix - ijob was set      
c                                  incorrectly                          
      ier = 65                                                          
      go to 9000                                                        
c                                  terminal error - matrix a is         
c                                  algorithmically singular             
   60 ier = 130                                                         
 9000 continue                                                          
c     call uertst(ier,'linv3f')                                         
 9005 return                                                            
      end                                                               
c
c
      subroutine logitcovar(parm)
c
c       this subroutine computes the covariance matrix for the mom 
c       logit estimates.
c
      parameter(nobss=26000,nobsss=nobss*2,nhouses=11,ncchars=80,
     & nccharts=2,npolys=2,ncars=10,ncarm1s=ncars-1,ncoefs=ncchars+13+
     & (npolys*3)+nhouses+ncarm1s,nbrs=23,nbr3s=nbrs+3,northogs=3,
     & northog2s=northogs*2)
      implicit real*8(a-h,o-z)
      character*2 star(3),start
      real hchar,propmil,summiles
      dimension anum(northogs,northogs),cov(northogs,northogs),
     & dnum(northogs,northogs),iaggv(nbr3s),parm(ncoefs),prob(ncars),
     & probc(ncars),work1(northogs),work2(northog2s),x(northogs)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
      data star/'  ','* ','**'/
c
c       initialize.
c
      nmodelp1=nmodel+1
      nmodelp2=nmodel+2
      call parset1(parm)
      call parset2
      northog=3
      do 9 i=1,northog
         do 9 j=1,northog
            anum(i,j)=0.d0
   9        dnum(i,j)=0.d0
c
c       compute orthogonality conditions for each household.
c
      nobst=0
      do 2 i=1,nobs
         ncart=ncar(i)
         if(ncart.le.1)goto 2
         nobst=nobst+1
c
c       compute linear indices.
c
         do 4 j=1,ncart
            prob(j)=0.d0
            ij=index(i)+j
            icchartr=iaggv(icchar(ij,1))
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            age=age/10.d0
            agetr=agetr/10.d0
            ktm=nmodelp2+((icchartr-1)*2)+1
   4        prob(j)=gamma(1)+(age*(alpha(nmodelp1)+
     &       alpha(ktm)))+(agetr*(alpha(nmodelp2)+alpha(ktm+1)))
c
c       compute maximum index.
c
         amxprob=-1.d20
         do 5 j=1,ncart
            if(amxprob.lt.prob(j))amxprob=prob(j)
   5        continue
c
c       adjust indices and exponentiate.
c
         denom=0.d0
         do 6 j=1,ncart
            prob(j)=exp(prob(j)-amxprob)
   6        denom=denom+prob(j)
         do 7 j=1,ncart
            prob(j)=prob(j)/denom
   7        probc(j)=1.d0-prob(j)
c
c       update matrices.
c
         x(1)=1.d0
         x(2)=age/10.d0
         x(3)=agetr/10.d0
         do 3 j=1,northog
            do 11 k=1,j
               do 12 l=1,ncart
                  il=index(i)+l
                  do 13 m=1,ncart
                     im=index(i)+m
                     if(l.eq.m)anum(j,k)=anum(j,k)+(x(j)*prob(l)*x(k))
                     if(l.ne.m)anum(j,k)=anum(j,k)-(x(j)*prob(l)*
     &                prob(m)*x(k))
  13                 dnum(j,k)=dnum(j,k)+(x(j)*prob(l)*probc(l)*x(k))
  12              continue
  11           continue
   3        continue
   2     continue
c
c       adjust and invert.
c
      do 10 i=1,northog
         do 10 j=1,i
            anum(i,j)=anum(i,j)/nobst
            anum(j,i)=anum(i,j)
            dnum(i,j)=dnum(i,j)/nobst
  10        dnum(j,i)=dnum(i,j)
      d1=-1.d0
      call linv3f(dnum,work1,1,northog,northogs,d1,d2,work2,ierl)
      if(ier.ne.0)then
         write(6,100)ier
 100     format(1x,'inversion problem: ier = ',i4)
         stop
         endif
c
c       multiply.
c
      do 14 i=1,northog
         do 14 j=1,i
            cov(i,j)=0.d0
            do 15 k=1,northog
               do 15 l=1,northog
  15              cov(i,j)=cov(i,j)+(dnum(i,k)*anum(k,l)*dnum(j,l))
  14        cov(j,i)=cov(i,j)
c
c       output covariance matrix.
c
      write(6,104)
 104  format(1x,50('-'))
      write(6,102)
 102  format(1x,'asymptotic covariance matrix:',//,'variable',2x,
     & 'covariance')  
      do 16 i=1,northog
  16     write(6,101)i,(cov(i,j),j=1,i)
 101  format(1x,i1,7x,3(2x,g15.8))
c
c       output t-statistics.
c
      write(6,104)
      write(6,105)
 105  format(1x,'estimates and t-statistics',/,1x,'variable',2x,
     & 'value',7x,'std dev',3x,'t-statistic')
      do 17 i=1,northog
         stddev=(cov(i,i)/nobst)**.5d0
         tstat=parm(i)/stddev
         atstat=abs(tstat)
         if(atstat.lt.1.53)start=star(1)
         if((atstat.ge.1.53).and.(atstat.lt.1.96))start=star(2)
         if(atstat.ge.1.96)start=star(3)
  17     write(6,103)i,parm(i),start,stddev,tstat
 103  format(1x,i1,9x,f8.3,a2,2(2x,f8.3))
      return
      end
c
c
      subroutine logitmom(parm,nparm,obj,ier)
c
c       this subroutine is the negative of the inner product of 
c       orthogonality conditions for the mom logit problem.
c
      parameter(nobss=26000,nobsss=nobss*2,nhouses=11,ncchars=80,
     & nccharts=2,npolys=2,ncars=10,ncarm1s=ncars-1,nbrs=23,
     & nbr3s=nbrs+3,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s,
     & northogs=3)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension iaggv(nbr3s),orthog(northogs),parm(ncoefs),prob(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
c
c       initialize.
c
      nmodelp1=nmodel+1
      nmodelp2=nmodel+2
      call parset1(parm)
      call parset2
      northog=3
      do 9 i=1,northog
   9     orthog(i)=0.d0
c
c       compute orthogonality conditions for each household.
c
      do 2 i=1,nobs
         ncart=ncar(i)
         if(ncart.le.1)goto 2
c
c       compute linear indices.
c
         do 4 j=1,ncart
            prob(j)=0.d0
            ij=index(i)+j
            icchartr=iaggv(icchar(ij,1))
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            age=age/10.d0
            agetr=agetr/10.d0
            ktm=nmodelp2+((icchartr-1)*2)+1
   4        prob(j)=gamma(1)+(age*(alpha(nmodelp1)+
     &       alpha(ktm)))+(agetr*(alpha(nmodelp2)+alpha(ktm+1)))
c
c       compute maximum index.
c
         amxprob=-1.d20
         do 5 j=1,ncart
            if(amxprob.lt.prob(j))amxprob=prob(j)
   5        continue
c
c       adjust indices and exponentiate.
c
         denom=0.d0
         do 6 j=1,ncart
            prob(j)=exp(prob(j)-amxprob)
   6        denom=denom+prob(j)
         do 7 j=1,ncart
   7        prob(j)=prob(j)/denom
c
c       construct residuals.
c
         do 3 j=1,ncart
            ij=index(i)+j
            icchartr=iaggv(icchar(ij,1))
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            age=age/10.d0
            agetr=agetr/10.d0
            resid=propmil(ij)-prob(j)
            orthog(1)=orthog(1)+resid
            orthog(2)=orthog(2)+(age*resid)
   3        orthog(3)=orthog(3)+(agetr*resid)
   2     continue
c
c       sum of squares.
c
      obj=0.d0
      do 10 i=1,3
  10     obj=obj-(orthog(i)*orthog(i))
      return
      end
c
c
      subroutine ludatn (a,ia,n,xlu,ilu,idgt,d1,d2,apvt,equil,wa,ier)   
c
c   imsl routine name   - ludatn                                        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
c   computer            - prim77/single                                 
c                                                                       
c   latest revision     - june 1, 1982                                  
c                                                                       
c   purpose             - nucleus called only by imsl subroutine leqt2f 
c                                                                       
c   precision/hardware  - single and double/h32                         
c                       - single/h36,h48,h60                            
c                                                                       
c   reqd. imsl routines -       
c                                                                       
c   notation            - information on special notation and           
c                           conventions is available in the manual      
c                           introduction or through imsl routine uhelp  
c                                                                       
c   copyright           - 1982 by imsl, inc. all rights reserved.       
c                                                                       
c   warranty            - imsl warrants only that imsl testing has been 
c                           applied to this code. no other warranty,    
c                           expressed or implied, is applicable.        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
      implicit real*8 (a-h,o-z)
c     implicit real*4 (a-h,o-z)
c                                                                       
      real*8          a(ia,n),xlu(ilu,ilu),apvt(ilu),equil(n)           
c     real*4          a(ia,n),xlu(ilu,ilu),apvt(ilu),equil(n)           
      data  zero,one,four,sixtn,sixth/0.d0,1.d0,4.d0,16.d0,.0625d0/     
c                                  first executable statement           
c                                  initialization                       
      ier = 0                                                           
      rn = n                                                            
      wrel = zero                                                       
      d1 = one                                                          
      d2 = zero                                                         
      biga = zero                                                       
      do 10 i=1,n                                                       
         big = zero                                                     
         do 5 j=1,n                                                     
            p = a(i,j)                                                  
            xlu(i,j) = p                                                
c           p = dabs(p)                                                 
            p = abs(p)                                                 
            if (p .gt. big) big = p                                     
    5    continue                                                       
         if (big .gt. biga) biga = big                                  
         if (big .eq. zero) go to 110                                   
         equil(i) = one/big                                             
   10 continue                                                          
      do 105 j=1,n                                                      
         jm1 = j-1                                                      
         if (jm1 .lt. 1) go to 40                                       
c                                  compute u(i,j), i=1,...,j-1          
         do 35 i=1,jm1                                                  
            sum = xlu(i,j)                                              
            im1 = i-1                                                   
            if (idgt .eq. 0) go to 25                                   
c                                  with accuracy test                   
c           ai = dabs(sum)                                              
            ai = abs(sum)                                              
            wi = zero                                                   
            if (im1 .lt. 1) go to 20                                    
            do 15 k=1,im1                                               
               t = xlu(i,k)*xlu(k,j)                                    
               sum = sum-t                                              
c              wi = wi+dabs(t)                                          
               wi = wi+abs(t)                                          
   15       continue                                                    
            xlu(i,j) = sum                                              
c  20       wi = wi+dabs(sum)                                           
   20       wi = wi+abs(sum)                                           
            if (ai .eq. zero) ai = biga                                 
            test = wi/ai                                                
            if (test .gt. wrel) wrel = test                             
            go to 35                                                    
c                                  without accuracy                     
   25       if (im1 .lt. 1) go to 35                                    
            do 30 k=1,im1                                               
               sum = sum-xlu(i,k)*xlu(k,j)                              
   30       continue                                                    
            xlu(i,j) = sum                                              
   35    continue                                                       
   40    p = zero                                                       
c                                  compute u(j,j) and l(i,j), i=j+1,...,
         do 70 i=j,n                                                    
            sum = xlu(i,j)                                              
            if (idgt .eq. 0) go to 55                                   
c                                  with accuracy test                   
c           ai = dabs(sum)                                              
            ai = abs(sum)                                              
            wi = zero                                                   
            if (jm1 .lt. 1) go to 50                                    
            do 45 k=1,jm1                                               
               t = xlu(i,k)*xlu(k,j)                                    
               sum = sum-t                                              
c              wi = wi+dabs(t)                                          
               wi = wi+abs(t)                                          
   45       continue                                                    
            xlu(i,j) = sum                                              
c  50       wi = wi+dabs(sum)                                           
   50       wi = wi+abs(sum)                                           
            if (ai .eq. zero) ai = biga                                 
            test = wi/ai                                                
            if (test .gt. wrel) wrel = test                             
            go to 65                                                    
c                                  without accuracy test                
   55       if (jm1 .lt. 1) go to 65                                    
            do 60 k=1,jm1                                               
               sum = sum-xlu(i,k)*xlu(k,j)                              
   60       continue                                                    
            xlu(i,j) = sum                                              
c  65       q = equil(i)*dabs(sum)                                      
   65       q = equil(i)*abs(sum)                                      
            if (p .ge. q) go to 70                                      
            p = q                                                       
            imax = i                                                    
   70    continue                                                       
c                                  test for algorithmic singularity     
         q = rn+p                                                       
   71    if (q .eq. rn) go to 110                                       
         if (j .eq. imax) go to 80                                      
c                                  interchange rows j and imax          
         d1 = -d1                                                       
         do 75 k=1,n                                                    
            p = xlu(imax,k)                                             
            xlu(imax,k) = xlu(j,k)                                      
            xlu(j,k) = p                                                
   75    continue                                                       
         equil(imax) = equil(j)                                         
   80    apvt(j) = imax                                                 
         d1 = d1*xlu(j,j)                                               
c  85    if (dabs(d1) .le. one) go to 90                                
   85    if (abs(d1) .le. one) go to 90                                
         d1 = d1*sixth                                                  
         d2 = d2+four                                                   
         go to 85                                                       
c  90    if (dabs(d1) .ge. sixth) go to 95                              
   90    if (abs(d1) .ge. sixth) go to 95                              
         d1 = d1*sixtn                                                  
         d2 = d2-four                                                   
         go to 90                                                       
   95    continue                                                       
         jp1 = j+1                                                      
         if (jp1 .gt. n) go to 105                                      
c                                  divide by pivot element u(j,j)       
         p = xlu(j,j)                                                   
         do 100 i=jp1,n                                                 
            xlu(i,j) = xlu(i,j)/p                                       
  100    continue                                                       
  105 continue                                                          
c                                  perform accuracy test                
      if (idgt .eq. 0) go to 9005                                       
      p = 3*n+3                                                         
      wa = p*wrel                                                       
      q = wa+10.0**(-idgt)                                              
  106 if (q .ne. wa) go to 9005                                         
      ier = 34                                                          
      go to 9000                                                        
c                                  algorithmic singularity              
  110 ier = 129                                                         
      d1 = zero                                                         
      d2 = zero                                                         
 9000 continue                                                          
c                                  print error                          
c     call uertst(ier,'ludatn')                                         
 9005 return                                                            
      end                                                               
c
c
      subroutine luelmn (a,ia,n,b,apvt,x)                               
c
c   imsl routine name   - luelmn                                        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
c   computer            - prim77/single                                 
c                                                                       
c   latest revision     - june 1, 1982                                  
c                                                                       
c   purpose             - nucleus called only by imsl subroutine leqt2f 
c                                                                       
c   reqd. imsl routines - none required                                 
c                                                                       
c   notation            - information on special notation and           
c                           conventions is available in the manual      
c                           introduction or through imsl routine uhelp  
c                                                                       
c   copyright           - 1982 by imsl, inc. all rights reserved.       
c                                                                       
c   warranty            - imsl warrants only that imsl testing has been 
c                           applied to this code. no other warranty,    
c                           expressed or implied, is applicable.        
c                                                                       
c-----------------------------------------------------------------------
c                                                                       
      implicit real*8 (a-h,o-z)
c     implicit real*4 (a-h,o-z)
c                                                                       
      real*8          a(ia,n),b(ia),apvt(ia),x(ia)                      
c     real*4          a(ia,n),b(ia),apvt(ia),x(ia)                      
c                                  first executable statement           
c                                  solve ly = b for y                   
      do 5 i=1,n                                                        
    5 x(i) = b(i)                                                       
      iw = 0                                                            
      do 20 i=1,n                                                       
         ip = apvt(i)                                                   
         sum = x(ip)                                                    
         x(ip) = x(i)                                                   
         if (iw .eq. 0) go to 15                                        
         im1 = i-1                                                      
         do 10 j=iw,im1                                                 
            sum = sum-a(i,j)*x(j)                                       
   10    continue                                                       
         go to 20                                                       
   15    if (sum .ne. 0.) iw = i                                        
   20 x(i) = sum                                                        
c                                  solve ux = y for x                   
      do 30 ib=1,n                                                      
         i = n+1-ib                                                     
         ip1 = i+1                                                      
         sum = x(i)                                                     
         if (ip1 .gt. n) go to 30                                       
         do 25 j=ip1,n                                                  
            sum = sum-a(i,j)*x(j)                                       
   25   continue                                                        
   30 x(i) = sum/a(i,i)                                                 
      return                                                            
      end                                                               
c
c
      subroutine mdnris (p,y,ier) 
c
c   imsl routine name   - mdnris
c 
c-----------------------------------------------------------------------
c 
c   computer            - cdcft5/single 
c 
c   latest revision     - november 1, 1984
c 
c   purpose             - inverse standard normal (gaussian)
c                           probability distribution function 
c 
c   usage               - call mdnris (p,y,ier) 
c 
c   arguments    p      - input value in the exclusive range (0.0,1.0)
c                y      - output value of the inverse normal (0,1)
c                           probability distribution function 
c                ier    - error parameter (output)
c                         terminal error
c                           ier = 129 indicates p lies outside the legal
c                             range. plus or minus machine infinity is
c                             given as the result (sign is the sign of
c                             the function value of the nearest legal 
c                             argument).
c 
c   precision/hardware  - single/all
c 
c   reqd. imsl routines - merfi
c 
c   notation            - information on special notation and 
c                           conventions is available in the manual
c                           introduction or through imsl routine uhelp
c 
c   copyright           - 1982 by imsl, inc. all rights reserved. 
c 
c   warranty            - imsl warrants only that imsl testing has been 
c                           applied to this code. no other warranty,
c                           expressed or implied, is applicable.
c 
c-----------------------------------------------------------------------
c 
c                                  specifications for arguments 
      real               p,y
      integer            ier
c                                  specifications for local variables 
      real               eps,g0,g1,g2,g3,h0,h1,h2,a,w,wi,sn,sd
      real               sigma,sqrt2,x,xinf 
      data               xinf/.12650140831e+323/
      data               sqrt2/1.4142135623731/ 
      data               eps/.710543e-14/ 
      data               g0/.18511591e-3/,g1/-.20281520e-2/ 
      data               g2/-.14983844/,g3/.10786386e-1/
      data               h0/.99529751e-1/,h1/.52117329/ 
      data               h2/-.68883009e-1/
c                                  first executable statement 
      ier = 0 
      if (p .gt. 0.0 .and. p .lt. 1.0) go to 5
      ier = 129 
      sigma = sign(1.0,p) 
      y = sigma * xinf
      go to 9000
    5 if(p.le.eps) go to 10 
      x = 1.0 -(p + p)
      call merfi (x,y,ier)
      y = -sqrt2 * y
      go to 9005
c                                  p too small, compute y directly
   10 a = p+p 
      w = sqrt(-alog(a+(a-a*a)))
c                                  use a rational function in 1./w
      wi = 1./w 
      sn = ((g3*wi+g2)*wi+g1)*wi
      sd = ((wi+h2)*wi+h1)*wi+h0
      y = w + w*(g0+sn/sd)
      y = -y*sqrt2
      go to 9005
 9000 continue
 9005 return
      end 
c
c
      subroutine merfi (p,y,ier)
c
c   imsl routine name   - merfi 
c 
c---------------------------------------------------------------------- 
c 
c   computer            - cdcft5/single 
c 
c   latest revision     - january 1, 1978 
c 
c   purpose             - inverse error function
c 
c   usage               - call merfi (p,y,ier)
c 
c   arguments    p      - input value in the exclusive range (-1.0,1.0) 
c                y      - output value of the inverse error function
c                ier    - error parameter (output)
c                         terminal error
c                           ier = 129 indicates p lies outside the lega 
c                             range. plus or minus machine infinity is
c                             given as the result (sign is the sign of
c                             the function value of the nearest legal 
c                             argument).
c 
c   precision/hardware  - single/all
c 
c   reqd. imsl routines - none required 
c 
c   notation            - information on special notation and 
c                           conventions is available in the manual
c                           introduction or through imsl routine uhelp
c 
c   copyright           - 1978 by imsl, inc. all rights reserved. 
c 
c   warranty            - imsl warrants only that imsl testing has been 
c                           applied to this code. no other warranty,
c                           expressed or implied, is applicable.
c 
c---------------------------------------------------------------------- 
c 
c                                  specifications for arguments 
      real               p,y
      integer            ier
c                                  specifications for local variables 
      real               a(65),h1,h2,h3,h4,xinf,x,sigma,z,w,x3,x4,x5, 
     *                   x6,b 
      integer            n,ipp,l,lb2
      data               a(1),a(2),a(3),a(4),a(5),a(6),a(7),a(8),a(9),
     *                   a(10),a(11),a(12),a(13),a(14),a(15),a(16), 
     *                   a(17),a(18),a(19),a(20),a(21),a(22),a(23)
     *                   /.99288537662,.12046751614,
     *                   .16078199342e-01,.26867044372e-02, 
     *                   .49963473024e-03,.98898218599e-04, 
     *                   .20391812764e-04,.4327271618e-05,
     *                   .938081413e-06,.206734721e-06, 
     *                   .46159699e-07,.10416680e-07, 
     *                   .2371501e-08,.543928e-09,
     *                   .125549e-09,.29138e-10,
     *                   .6795e-11,.1591e-11, 
     *                   .374e-12,.88e-13,
     *                   .21e-13,.5e-14,
     *                   .1e-14/
      data               a(24),a(25),a(26),a(27),a(28),a(29),a(30), 
     *                   a(31),a(32),a(33),a(34),a(35),a(36),a(37), 
     *                   a(38),a(39),a(40)
     *                   /.91215880342e00,-.16266281868e-01,
     *                   .43355647295e-03,.21443857007e-03, 
     *                   .2625751076e-05,-.302109105e-05, 
     *                   -.12406062e-07,.62406609e-07,
     *                   -.540125e-09,-.142328e-08, 
     *                   .34384e-10,.33585e-10, 
     *                   -.1458e-11,-.81e-12, 
     *                   .53e-13,.2e-13,
     *                   -.2e-14/ 
      data               a(41),a(42),a(43),a(44),a(45),a(46),a(47), 
     *                   a(48),a(49),a(50),a(51),a(52),a(53),a(54), 
     *                   a(55),a(56),a(57),a(58),a(59),a(60),a(61), 
     *                   a(62),a(63),a(64),a(65)
     *                   /.95667970902,-.023107004309,
     *                   -.43742360975e-02,-.57650342265e-03, 
     *                   -.10961022307e-04,.25108547025e-04,
     *                   .10562336068e-04,.275441233e-05, 
     *                   .432484498e-06,-.20530337e-07, 
     *                   -.43891537e-07,-.1768401e-07,
     *                   -.3991289e-08,-.186932e-09,
     *                   .272923e-09,.132817e-09, 
     *                   .31834e-10,.1670e-11,
     *                   -.2036e-11,-.965e-12,
     *                   -.22e-12,-.1e-13,
     *                   .13e-13,.6e-14,
     *                   .1e-14/
      data               h1,h2,h3,h4/-1.5488130424, 
     *                   2.5654901231,-.55945763133,
     *                   2.2879157163/
      data               xinf/.12650140831e+323/
c                                  first executable statement 
      x = p 
      ier = 0 
      sigma = sign(1.,x)
      if (.not.(x.gt.-1..and.x.lt.1.)) go to 35 
      z = abs(x)
      if(z.gt..8) go to 20
      w = z*z/.32-1.
      n = 22
      ipp = 1 
      l = 1 
    5 lb2 = 1 
      x3 = 1. 
      x4 = w
      x6 = a(ipp) 
   10 x6 = x6 + a(ipp+lb2) * x4 
      x5 = x4 * w * 2.-x3 
      x3 = x4 
      x4 = x5 
      lb2 = lb2 + 1 
      if (lb2 .le. n) go to 10
      go to (15,30),l 
   15 y = z * x6 * sigma
      go to 9005
   20 b = sqrt(-alog(1.-z*z)) 
      if (z .gt. .9975) go to 25
      w = h1*b+h2 
      ipp = 24
      l = 2 
      n = 16
      go to 5 
   25 w = h3 * b + h4 
      ipp = 41
      n = 24
      l = 2 
      go to 5 
   30 y = b * x6 * sigma
      go to 9005
   35 y = sigma*xinf
      ier = 129 
 9000 continue
 9005 return
      end 
c
c
      subroutine momlogit
c
c       this subroutine estimates a logit model of proportion of miles 
c       for each car in a household using a multinomial logit model.  
c       it uses the simplex routine in gqopt for optimization.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 alabel,alabelt(ncoefs)
      dimension parm(ncoefs),parmold(ncoefs)
      common/best/fbest(3)
      common/bnel/stp,var,konvge,nrst
      common/bstack/aint(10000)
      common/bstak/nq,ntop
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      external logitmom,nmsimp
      do 8 i=1,3
   8     fbest(i)=-1.d20
      niter=100
      mx=1
      acc=.1d-3
      nrst=5
      nbr=23
      nparm=0
      do 4 i=1,ncoef
         if(icoef(i).eq.0)then
            nparm=nparm+1
            parm(nparm)=coef(i)
            parmold(nparm)=parm(nparm)
            alabelt(nparm)=alabel(i)
            endif
   4     continue
      nq=(nparm*nparm)+(4*nparm)+1
      call logitmom(parm,nparm,objold,ier)
      do 2 i=1,8
         stp=.01d0
         call opt(parm,nparm,obj,nmsimp,niter,mx,ier,acc,logitmom,
     &    alabelt)
         parm2=0.d0
         do 3 j=1,nparm
            dparm=parm(j)-parmold(j)
            parmold(j)=parm(j)
   3        parm2=parm2+(dparm*dparm)
         parm2=(parm2/nparm)**.5d0
         dobj=abs(obj-objold)/objold
         write(6,101)i,parm2,dobj
 101     format(1x,'iteration ',i1,': parm2 = ',g15.8,' dobj = ',g15.8)
         if((parm2.lt..1d-2).and.(abs(dobj).lt..1d-4))then
            write(6,100)
 100        format(1x,'convergence reached')
            call logitcovar(parm)
            return
            endif
         objold=obj
   2     continue
   5  continue
      write(6,102)
 102  format(1x,'no convergence reached')
      stop
      end
c
c
      subroutine ols
c
c       this subroutine estimates an ols model of log miles on car 
c       characteristics and then car characteristics, number of other 
c       cars in household, and family characteristics.
c
      parameter(nccharts=2,nhouses=11,nobss=26000,nobsss=nobss*2,
     & nbrs=23,nbr3s=nbrs+3,nx1s=nbrs+3,nx2s=nx1s+(2*nbrs)-1,nx3s=nx1s+
     & nhouses,nx4s=nx3s+(2*nbrs)-1,nx42s=nx4s*2,nx4ss=nx4s*(nx4s+1)/2)
      implicit real*8(a-h,o-z)
      character*2 astar(3),astart
      character*8 aclab1(nx1s),aclab2(nx2s),aclab3(nx3s),aclab4(nx4s)
      real hchar,propmil,summiles
      dimension bhat(nx4s),cov(nx4s,nx4s),eigval(nx4s),
     & eigvec(nx4s,nx4s),itrnsl(nbr3s),sig(2),work1(nx4s),work2(nx42s),
     & xxhold(nx4ss),xx1(nx1s,nx1s),xx2(nx2s,nx2s),xx3(nx3s,nx3s),
     & xx4(nx4s,nx4s),xy1(nx1s),xy2(nx2s),xy3(nx3s),xy4(nx4s),x1(nx1s),
     & x2(nx2s),x3(nx3s),x4(nx4s)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      data aclab1/'constant','age','agetr','chrysler','dodge',
     & 'plymouth','ford','mercury','buick','chevrolt','oldsmobl',
     & 'pontiac','saturn','luxamer','luxjapan','luxeurop','honda',
     & 'mitsubi','mazda','nissan','subaru','toyota','volkswg','volvo',
     & 'geo','truck'/
      data aclab2/'constant','age','chrysler','dodge','plymouth',
     & 'ford','mercury','buick','chevrolt','oldsmobl','pontiac',
     & 'saturn','luxamer','luxjapan','luxeurop','honda','mitsubi',
     & 'mazda','nissan','subaru','toyota','volkswg','volvo','geo',
     & 'truck','chryslra','dodgea','plymotha','forda','mercurya',
     & 'buicka','chvrolta','oldsmbla','pontiaca','saturna','luxamera',
     & 'luxjpana','luxeurpa','hondaa','mitsubia','mazdaa','nissana',
     & 'subarua','toyotaa','volkswga','volvoa','geoa','trucka',
     & 'chryslrb','dodgeb','plymothb','fordb','mercuryb','buickb',
     & 'chvroltb','oldsmblb','pontiacb','saturnb','luxamerb',
     & 'luxjpanb','luxeurpb','hondab','mitsubib','mazdab','nissanb',
     & 'subarub','toyotab','volkswgb','volvob','geob','truckb'/
      data aclab3/'constant','age','agetr','chrysler','dodge',
     & 'plymouth','ford','mercury','buick','chevrolt','oldsmobl',
     & 'pontiac','saturn','luxamer','luxjapan','luxeurop','honda',
     & 'mitsubi','mazda','nissan','subaru','toyota','volkswg','volvo',
     & 'geo','truck','ncars','lincome','urban','drvrs','drvrst',
     & 'adrvrs','adrvrst','mdrvrs','mdrvrst','wdrvrs','wdrvrst'/
      data aclab4/'constant','age','chrysler','dodge','plymouth',
     & 'ford','mercury','buick','chevrolt','oldsmobl','pontiac',
     & 'saturn','luxamer','luxjapan','luxeurop','honda','mitsubi',
     & 'mazda','nissan','subaru','toyota','volkswg','volvo','geo',
     & 'truck','chryslra','dodgea','plymotha','forda','mercurya',
     & 'buicka','chvrolta','oldsmbla','pontiaca','saturna','luxamera',
     & 'luxjpana','luxeurpa','hondaa','mitsubia','mazdaa','nissana',
     & 'subarua','toyotaa','volkswga','volvoa','geoa','trucka',
     & 'chryslrb','dodgeb','plymothb','fordb','mercuryb','buickb',
     & 'chvroltb','oldsmblb','pontiacb','saturnb','luxamerb',
     & 'luxjpanb','luxeurpb','hondab','mitsubib','mazdab','nissanb',
     & 'subarub','toyotab','volkswgb','volvob','geob','truckb','ncars',
     & 'lincome','urban','drvrs','drvrst','adrvrs','adrvrst','mdrvrs',
     & 'mdrvrst','wdrvrs','wdrvrst'/
      data astar/'  ','* ','**'/
      data itrnsl/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     & 21,22,0,0,23/
c
c       initialize.
c
      nbr=23
      nx1=nbr+3
      nx1m1=nx1-1
      nx2=nx1+(2*nbr)-1
      nx3=nx1+nhouse
      nx4=nx3+(2*nbr)-1
      do 4 i=1,nx1
         xy1(i)=0.d0
         do 4 j=1,i
   4        xx1(i,j)=0.d0
      do 8 i=1,nx2
         xy2(i)=0.d0
         do 8 j=1,i
   8        xx2(i,j)=0.d0
      do 12 i=1,nx3
         xy3(i)=0.d0
         do 12 j=1,i
  12        xx3(i,j)=0.d0
      do 15 i=1,nx4
         xy4(i)=0.d0
         do 15 j=1,i
  15        xx4(i,j)=0.d0
c
c       construct necessary matrices.
c
      do 2 i=1,nobs
         if(((i/1000)*1000).eq.i)write(6,133)i
 133     format(1x,'i = ',i6)
         ncart=ncar(i)
         do 6 j=1,ncart
c
c       construct car characteristics vector.
c
            ij=index(i)+j
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            x1(1)=1.d0
            x1(2)=age/10.d0
            x1(3)=agetr/10.d0
            do 5 k=1,nbr
               k3=k+3
   5           x1(k3)=0.d0
            itrnt=itrnsl(icchar(ij,1))
            if(itrnt.gt.0)x1(itrnt+3)=1.d0
            do 50 k=1,2
               x2(k)=x1(k)
  50           x3(k)=x1(k)
            x3(3)=x1(3)
            do 9 k=4,nx1
               x2(k-1)=x1(k)
   9           x3(k)=x1(k)
            do 10 k=nx1,nx2
  10           x2(k)=0.d0
            if(itrnt.gt.0)then
               x2(nx1m1+itrnt)=age/10.
               x2(nx1m1+nbr+itrnt)=agetr/10.
               endif 
            x3(nx1+1)=dble(float(ncar(i)))
            do 13 k=2,nhouse
  13           x3(nx1+k)=dble(hchar(i,k))
            do 16 k=1,nx2
  16           x4(k)=x2(k)
            x4(nx2+1)=dble(float(ncar(i)))
            do 17 k=2,nhouse
  17           x4(nx2+k)=dble(hchar(i,k))
c
c       construct inner products.
c
            amiles=log(dble(summiles(i)*propmil(ij)))
            do 3 k=1,nx1
               xy1(k)=xy1(k)+(x1(k)*amiles)
               do 3 l=1,k  
   3              xx1(k,l)=xx1(k,l)+(x1(k)*x1(l))
            do 7 k=1,nx2
               xy2(k)=xy2(k)+(x2(k)*amiles)
               do 7 l=1,k
   7              xx2(k,l)=xx2(k,l)+(x2(k)*x2(l))
            do 11 k=1,nx3
               xy3(k)=xy3(k)+(x3(k)*amiles)
               do 11 l=1,k
  11              xx3(k,l)=xx3(k,l)+(x3(k)*x3(l))
            do 14 k=1,nx4
               xy4(k)=xy4(k)+(x4(k)*amiles)
               do 14 l=1,k
  14              xx4(k,l)=xx4(k,l)+(x4(k)*x4(l))
   6        continue
   2     continue
c
c       fill in matrices.
c
      do 19 i=1,nx1
         do 19 j=1,i
  19        xx1(j,i)=xx1(i,j)
      do 20 i=1,nx2
         do 20 j=1,i
  20        xx2(j,i)=xx2(i,j)
      do 21 i=1,nx3
         do 21 j=1,i
  21        xx3(j,i)=xx3(i,j)
      do 22 i=1,nx4
         do 22 j=1,i
  22        xx4(j,i)=xx4(i,j)
c
c       invert and multiply for first regression.
c
      ij=0
      do 30 i=1,nx1
         do 30 j=1,i
            ij=ij+1
  30        xxhold(ij)=xx1(i,j)/(xx1(i,i)*xx1(j,j))**.5d0
      d1=-1.d0
      call linv3f(xx1,work1,1,nx1,nx1s,d1,d2,work2,ierl)
      if(ierl.ne.0)write(6,100)1,ierl
 100  format(1x,'problem with regression ',i1,' ier = ',i3)
      call eigrs(xxhold,nx1,1,eigval,eigvec,nx4s,work1,ier)
      iflag=0
      do 31 i=1,nx1
         if(eigval(i).le..1d-3)then
            if(iflag.eq.0)then
               write(6,105)
 105           format(1x,'problem eigenvectors:',/,1x,'#',3x,
     &          'eigenvalue',7x,'eigenvector')
               iflag=1
               endif
            write(6,104)i,eigval(i),(eigvec(j,i),j=1,nx1)
 104        format(1x,i2,g15.8,4(2x,g15.8),24(/,18x,4(2x,g15.8)))
            endif
  31     continue
      if(ierl.ne.0)stop
      do 18 i=1,nx1
         bhat(i)=0.d0
         do 18 j=1,nx1
  18        bhat(i)=bhat(i)+(xx1(i,j)*xy1(j))
c
c       compute covariance matrix for first regression.
c
      call covols(1,bhat,cov,sig)
c
c       report results for first regression.
c
      write(6,102)
 102  format(1x,50('-'))
      write(6,103)1
 103  format(1x,'results for regression ',i1,/,1x,'variable',2x,'value',
     & 7x,'std err',3x,'t-stat')
      do 23 i=1,nx1
         stderr=cov(i,i)**.5d0
         tstat=bhat(i)/stderr
         atstat=abs(tstat)
         if(atstat.lt.1.54)astart=astar(1)
         if((atstat.ge.1.54).and.(atstat.lt.1.96))astart=astar(2)
         if(atstat.ge.1.96)astart=astar(3)
  23     write(6,101)aclab1(i),bhat(i),astart,stderr,tstat
 101  format(1x,a8,2x,f8.3,a2,2(2x,f8.3))
      write(6,121)(sig(i),i=1,2)
 121  format(1x,'household effect: ',g15.8,/,1x,'vehicle effect: ',
     & g15.8)
      call waldtest(1,bhat,nx1,cov)
c
c       invert and multiply for second regression.
c
      ij=0
      do 32 i=1,nx2
         do 32 j=1,i
            ij=ij+1
  32        xxhold(ij)=xx2(i,j)/(xx2(i,i)*xx2(j,j))**.5d0
      d1=-1.d0
      call linv3f(xx2,work1,1,nx2,nx2s,d1,d2,work2,ierl)
      if(ierl.ne.0)write(6,100)2,ierl
      call eigrs(xxhold,nx2,1,eigval,eigvec,nx4s,work1,ier)
      iflag=0
      do 33 i=1,nx2
         if(eigval(i).le..1d-3)then
            if(iflag.eq.0)then
               write(6,105)
               iflag=1
               endif
            write(6,104)i,eigval(i),(eigvec(j,i),j=1,nx2)
            endif
  33     continue
      if(ierl.ne.0)stop
      do 24 i=1,nx2
         bhat(i)=0.d0
         do 24 j=1,nx2
  24        bhat(i)=bhat(i)+(xx2(i,j)*xy2(j))
c
c       compute covariance matrix for second regression.
c
      call covols(2,bhat,cov,sig)
c
c       report results for second regression.
c
      write(6,102)
      write(6,103)2
      do 25 i=1,nx2
         stderr=cov(i,i)**.5d0
         tstat=bhat(i)/stderr
         atstat=abs(tstat)
         if(atstat.lt.1.54)astart=astar(1)
         if((atstat.ge.1.54).and.(atstat.lt.1.96))astart=astar(2)
         if(atstat.ge.1.96)astart=astar(3)
  25     write(6,101)aclab2(i),bhat(i),astart,stderr,tstat
      write(6,121)(sig(i),i=1,2)
      call waldtest(2,bhat,nx2,cov)
c
c       invert and multiply for third regression.
c
      ij=0
      do 34 i=1,nx3
         do 34 j=1,i
            ij=ij+1
  34        xxhold(ij)=xx3(i,j)/(xx3(i,i)*xx3(j,j))**.5d0
      d1=-1.d0
      call linv3f(xx3,work1,1,nx3,nx3s,d1,d2,work2,ierl)
      if(ierl.ne.0)write(6,100)3,ierl
      call eigrs(xxhold,nx3,1,eigval,eigvec,nx4s,work1,ier)
      iflag=0
      do 35 i=1,nx3
         if(eigval(i).le..1d-3)then
            if(iflag.eq.0)then
               write(6,105)
               iflag=1
               endif
            write(6,104)i,eigval(i),(eigvec(j,i),j=1,nx3)
            endif
  35     continue
      if(ierl.ne.0)stop
      do 26 i=1,nx3
         bhat(i)=0.d0
         do 26 j=1,nx3
  26        bhat(i)=bhat(i)+(xx3(i,j)*xy3(j))
c
c       compute covariance matrix for third regression.
c
      call covols(3,bhat,cov,sig)
c
c       report results for third regression.
c
      write(6,102)
      write(6,103)3
      do 27 i=1,nx3
         stderr=cov(i,i)**.5d0
         tstat=bhat(i)/stderr
         atstat=abs(tstat)
         if(atstat.lt.1.54)astart=astar(1)
         if((atstat.ge.1.54).and.(atstat.lt.1.96))astart=astar(2)
         if(atstat.ge.1.96)astart=astar(3)
  27     write(6,101)aclab3(i),bhat(i),astart,stderr,tstat
      write(6,121)(sig(i),i=1,2)
      call waldtest(3,bhat,nx3,cov)
c
c       invert and multiply for fourth regression.
c
      ij=0
      do 36 i=1,nx4
         do 36 j=1,i
            ij=ij+1
  36        xxhold(ij)=xx4(i,j)/(xx4(i,i)*xx4(j,j))**.5d0
      d1=-1.d0
      call linv3f(xx4,work1,1,nx4,nx4s,d1,d2,work2,ierl)
      if(ierl.ne.0)write(6,100)4,ierl
      call eigrs(xxhold,nx4,1,eigval,eigvec,nx4s,work1,ier)
      iflag=0
      do 37 i=1,nx4
         if(eigval(i).le..1d-3)then
            if(iflag.eq.0)then
               write(6,105)
               iflag=1
               endif
            write(6,104)i,eigval(i),(eigvec(j,i),j=1,nx4)
            endif
  37     continue
      if(ierl.ne.0)stop
      do 28 i=1,nx4
         bhat(i)=0.d0
         do 28 j=1,nx4
  28        bhat(i)=bhat(i)+(xx4(i,j)*xy4(j))
c
c       compute covariance matrix for fourth regression.
c
      call covols(4,bhat,cov,sig)
c
c       report results for fourth regression.
c
      write(6,102)
      write(6,103)4
      do 29 i=1,nx4
         stderr=cov(i,i)**.5d0
         tstat=bhat(i)/stderr
         atstat=abs(tstat)
         if(atstat.lt.1.54)astart=astar(1)
         if((atstat.ge.1.54).and.(atstat.lt.1.96))astart=astar(2)
         if(atstat.ge.1.96)astart=astar(3)
  29     write(6,101)aclab4(i),bhat(i),astart,stderr,tstat
      write(6,121)(sig(i),i=1,2)
      call waldtest(4,bhat,nx4,cov)
      return
      end
c
c
      subroutine parget(method,parm,nparm)
c
c       this subroutine reads parameters.
c
      parameter(ncchars=80,nccharts=2,npolys=2,nhouses=11,ncars=10,
     & ncarm1s=ncars-1,nobss=26000,nobsss=nobss*2,ncoefs=ncchars+13+
     & (npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 ajunk,alabel
      real hchar,propmil,summiles
      dimension parm(ncoefs)
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/speccase/ishare,itotmil
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      open(unit=8,file='nptsestimate.p')
      read(8,*)method,nobs,nmodel,ncchar,nhouse,ncarmax,npoly,ishare,
     & itotmil
      write(6,101)method,nobs,nmodel,ncchar,nhouse,ncarmax,npoly,
     & ishare,itotmil
 101  format(1x,'method = ',i2,/,1x,'nobs = ',i6,/,1x,'nmodel = ',i2,/,
     & 1x,'ncchar = ',i2,/,1x,'nhouse = ',i2,/,1x,'ncarmax = ',i2,/,1x,
     & 'npoly = ',i2,/,1x,'ishare = ',i1,/,1x,'itotmil = ',i1)
      if((ishare.ne.1).and.(itotmil.ne.1))then
         write(6,102)
 102     format(1x,'ishare and itotmil are both 0')
         stop
         endif
      ncoef=ncchar+13+(npoly*3)+nhouse+ncarmax
      read(8,*)(coef(i),i=1,ncoef)
      read(8,*)(icoef(i),i=1,ncoef)
      write(6,103)(icoef(i),i=1,ncoef)
 103  format(1x,'icoef = ',20(i1,1x),5(/,9x,20(i1,1x)))
      nparm=0
      read(8,100)ajunk
 100  format(a8)
      do 2 i=1,ncoef
         read(8,100)ajunk
         if(icoef(i).eq.0)then
            nparm=nparm+1
            parm(nparm)=coef(i)
            alabel(nparm)=ajunk
            endif
   2     continue
      close(8)
      return
      end
c
c
      subroutine parset1(parm)
c
c       this subroutine puts parm into coef.
c
      parameter(ncchars=80,npolys=2,nhouses=11,ncars=10,ncarm1s=
     & ncars-1,ncoefs=ncchars+13+(npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 alabel
      dimension parm(ncoefs)
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      iparm=0
      do 2 i=1,ncoef
         if(icoef(i).eq.0)then
            iparm=iparm+1
            coef(i)=parm(iparm)
            endif
   2     continue
      return
      end
c
c
      subroutine parset2
c
c       this subroutine computes theta given coef.
c
      parameter(nobss=26000,nobsss=nobss*2,ncars=10,ncarm1s=ncars-1,
     & ncchars=80,nccharts=2,npolys=2,nhouses=11,ncoefs=ncchars+13+
     & (npolys*3)+nhouses+ncarm1s)
      implicit real*8(a-h,o-z)
      character*8 alabel
      real hchar,propmil,summiles
      common/coefs/alabel(ncoefs),coef(ncoefs),icoef(ncoefs),ncoef
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
c
c       get alpha.
c
      do 2 i=1,ncchar
   2     alpha(i)=coef(i)
c
c       get beta.
c
      it=ncchar
      do 3 i=1,4
         do 3 j=1,4
   3        beta(i,j)=0.d0
      do 4 i=1,4
         do 4 j=i,4
            it=it+1
   4        beta(i,j)=coef(it)
c
c       get delta.
c
      do 5 i=1,3
         do 5 j=1,npoly
            it=it+1
   5        delta(i,j)=coef(it)
c
c       get gamma.
c
      do 6 i=1,nhouse
         it=it+1
   6     gamma(i)=coef(it)
c
c       get omega.
c
      do 7 i=1,ncarmax
         it=it+1
   7     omega(i)=exp(coef(it))
c
c       get sigu.
c
      it=it+1
      sigu=exp(coef(it))
      do 8 i=1,4
         do 8 j=1,4
            beta1adj(i,j)=0.d0
   8        beta2adj(i,j)=0.d0
      it=it+1
      beta1adj(1,2)=coef(it)
      it=it+1
      beta2adj(1,2)=coef(it)
      return
      end
c
c
      subroutine plotdprep
c
c       this subroutine prepares data for plotmiles.
c
      parameter(nbrands=26,nccharts=2,nhouses=11,nobss=26000,
     & nobsss=nobss*2)
      implicit real*8(a-h,o-z)
      real ainc(26),hchar,propmil,summiles
      dimension ncarv(26)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      data ainc/0.,43.154,40.758,38.961,40.725,38.790,37.966,36.883,
     & 35.947,39.967,57.394,48.842,80.498,66.764,54.707,48.085,57.241,
     & 47.841,47.979,53.140,52.293,81.836,42.116,0.,26.619,0./
      data ncarv/0,1,1,1,1,1,1,1,1,1,1,1,2,1,1,2,2,1,1,1,2,2,1,0,1,0/
      nbrand=26
      nage=13
      index(1)=0
      nobs=0
      do 2 i=1,nbrand
         if(ncarv(i).eq.0)goto 2 
         do 4 j=1,nage
            nobs=nobs+1
            hchar(nobs,1)=1.
            hchar(nobs,2)=log(ainc(i))
            hchar(nobs,3)=1.
            hchar(nobs,4)=2.
            hchar(nobs,5)=hchar(nobs,4)
            if(hchar(nobs,5).gt.2.)hchar(nobs,5)=2.
            hchar(nobs,6)=hchar(nobs,4)
            hchar(nobs,7)=hchar(nobs,6)
            if(hchar(nobs,7).gt.2.)hchar(nobs,7)=2.
            hchar(nobs,8)=1.
            hchar(nobs,9)=hchar(nobs,8)
            if(hchar(nobs,9).gt.2.)hchar(nobs,9)=2.
            hchar(nobs,10)=hchar(nobs,6)
            hchar(nobs,11)=hchar(nobs,10)
            if(hchar(nobs,11).gt.2.)hchar(nobs,11)=2.
            ncar(nobs)=ncarv(i)
            ncart=ncar(nobs)
            ijk=index(nobs)
            do 3 k=1,ncart
               ijk=ijk+1
               icchar(ijk,1)=i
               if(k.eq.1)icchar(ijk,2)=j
               if(k.gt.1)icchar(ijk,2)=4
   3           continue
   4        index(nobs+1)=index(nobs)+ncar(nobs)
   2     continue
      close(8)
      return
      end
c
c
      subroutine plotmiles(parm)
c
c       this subroutine plots miles by brand and age using monica's 
c       "average household" characteristics and estimated parameters.
c
      parameter(nages=13,nbrands=26,ncars=10,ncarm1s=ncars-1,
     & ncchars=80,nccharts=2,nhouses=11,npolys=2,ncoefs=ncchars+13+
     & (npolys*3)+nhouses+ncarm1s,nobss=26000,nobsss=nobss*2)
      implicit real*8(a-h,o-z)
      character*8 abrand(nbrands),hhchars(nhouses)
      real et,hchar,propmil,rand2,summiles,u(ncars),ut
      dimension amiles(nbrands,nages),ncarv(nbrands),parm(ncoefs),
     & uhat(ncars),usum(5)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      data abrand/'isuzu','chrysler','dodge','plymouth','ford',
     & 'mercury','buick','chevrolt','oldsmobl','pontiac','saturn',
     & 'luxamer','luxjapan','luxeurop','honda','mitsubi','mazda',
     & 'nissan','subaru','toyota','volkswg','volvo','geo','hyundai',
     & 'other','truck'/
      data hhchars/'constant','lincome','urban','drvrs','drvrst',
     & 'adrvrs','adrvrst','mdrvrs','mdrvrst','wdrvrs','wdrvrst'/
      data ncarv/0,1,1,1,1,1,1,1,1,1,1,1,2,1,1,2,2,1,1,1,2,2,1,0,1,0/
c
c       initialize.
c
      nbrand=26
      nage=13
      nobs=nbrand*nage
      nrplot=1000
      anrplot=dble(float(nrplot))*2.d0
      iseed=1
      ut=rand2(iseed)
      iseed=0
      do 13 i=1,3
  13     usum(i)=0.d0
      usum(4)=1.d20
      usum(5)=-1.d20
      call parset1(parm)
      call parset2
      call plotdprep
      call shareinit
      do 10 i=1,nbrand
         do 10 j=1,nage
  10        amiles(i,j)=0.d0
c
c       simulate with antithetic acceleration.
c
      do 4 i=1,nrplot
         if(((i/50)*50).eq.i)write(6,110)i
 110     format(1x,'i = ',i5)
         do 7 j=1,2
            if(j.eq.1)then
               do 5 k=1,ncarmax
                  ut=rand2(iseed)
                  usum(1)=usum(1)+1.d0
                  dut=dble(ut)
                  usum(2)=usum(2)+dut
                  usum(3)=usum(3)+(dut*dut)
                  if(usum(4).gt.dut)usum(4)=dut
                  if(usum(5).lt.dut)usum(5)=dut
                  iseed=0
                  call utrunc(ut)
                  call mdnris(ut,et,ier)
   5              u(k)=et*sigu
               endif
            if(j.eq.2)then
               do 8 k=1,ncarmax
   8              u(k)=-1.d0*u(k)
               endif
c
c       plot for each brand.
c
            kl=0
            do 2 k=1,nbrand
c
c       compute household characteristics term.
c
               if(ncarv(k).eq.0)goto 2
c
c       compute mileage for each age.
c
               do 6 l=1,ncarmax
   6              uhat(l)=dble(u(l))
               do 3 l=1,nage
                  kl=kl+1
                  iobs=kl
                  if(l.eq.1)then
                     ncart=ncar(kl)
                     prdsm=0.d0
                     do 9 m=1,nhouse
   9                    prdsm=prdsm+(gamma(m)*dble(hchar(kl,m)))
                     endif
                  call sharep(uhat,ncart,nuhat,propmiles)
                  umax=uhat(nuhat)
                  call heval(ncart,prdsm,umax,totmiles,0)
   3              amiles(k,l)=amiles(k,l)+totmiles+log(propmiles)
   2           continue
   7        continue
   4     continue
c
c       report properties of uniform sampling.
c
      usum(2)=usum(2)/usum(1)
      usum(3)=((usum(3)/usum(1))-(usum(2)*usum(2)))**.5d0
      write(6,111)(usum(i),i=1,5)
 111  format(1x,'properties of uniform sampling:',/,1x,'# obs: ',g15.8,
     & /,1x,'mean: ',g15.8,/,1x,'std dev: ',g15.8,/,1x,'minimum: ',
     & g15.8,/,1x,'maximum: ',g15.8)
c
c       adjust and output.
c
      do 11 i=1,nbrand
         if(ncarv(i).eq.0)goto 11
         write(6,104)
 104     format(1x,50('='))
         write(6,101)abrand(i)
 101     format(1x,'mileage profile for brand: ',a8)
         write(6,102)(hhchars(j),hchar(i,j),j=1,nhouse)
 102     format(1x,'household profile:',11(/,1x,a8,': ',f8.4))
         write(6,103)
 103     format(1x,'age',2x,'log miles')
         do 12 j=1,nage
            amiles(i,j)=amiles(i,j)/anrplot
  12        write(6,100)j,amiles(i,j)
 100     format(1x,i2,3x,f8.4)
  11     continue
      return
      end
c
c
      function rand2(idum)
      dimension v(97)
      if (idum.ne.0) then
        temp=rand()
        do 1 j=1,97
          temp=rand()
    1     continue
        do 2 k=1,97
          v(k)=rand()
    2     continue
          y=rand()
          endif
      j=1+int(97*y)
      y=v(j)
      rand2=y
      v(j)=rand()
      return
      end
c
c
      subroutine share(uhat,ncartm1,obj)
c
c       this subroutine is the (negative) sum of squared residuals 
c       between mileage shares and predicted mileage shares.
c
      parameter(ncars=10,ncarm1s=ncars-1,ncchars=80,nccharts=2,
     & nhouses=11,npolys=2,nobss=26000,nobsss=nobss*2,ngrids=10,
     & ngridp1s=ngrids+1)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension epsi(ncars),itrnsl(ncars),psi(ncars),uhat(ncars),
     & v(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/sharestf/g(ncars)
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      if(ncartm1.eq.0)then
         vor(1)=vinit(iobs,1)+uhat(1)
         return
         endif
      ncart=ncartm1+1
c
c       compute v conditional on u.
c
      do 2 i=1,ncartm1
   2     v(i)=vinit(iobs,i)+uhat(i)
      v(ncart)=vinit(iobs,ncart)
c
c       order v.
c
      vor(1)=v(1)
      itrnsl(1)=1
      do 3 i=2,ncart
         im1=i-1
         do 4 j=1,im1
            if(v(i).gt.vor(j))then
               kt=i
               do 5 k=j,im1
                  kt=kt-1
                  vor(kt+1)=vor(kt)
   5              itrnsl(kt+1)=itrnsl(kt)
               vor(j)=v(i)
               itrnsl(j)=i
               goto 3
               endif
   4        continue
         vor(i)=v(i)
         itrnsl(i)=i
   3     continue
c
c       compute psi.
c
      itr=itrnsl(ncart)
      psi(itr)=0.d0
      it=ncart
      do 6 i=2,ncart
         itp1=it
         it=it-1
         itr=itrnsl(it)
         itm=it
         if(itm.gt.ncarmax)itm=ncarmax
   6     psi(itr)=psi(itrnsl(itp1))+(omega(itm)*(vor(it)-vor(itp1)))
c
c       compute exp(psi) and denominator.
c
      amxpsi=psi(itrnsl(1))
      denom=0.d0
      do 7 i=1,ncart
         epsi(i)=exp(psi(i)-amxpsi)
   7     denom=denom+epsi(i)
c
c       compute g.
c
      do 8 i=1,ncart
   8     g(i)=epsi(i)/denom
c
c       compute residual, square, and add.
c
      obj=0.d0
      do 9 i=1,ncart
         ii=index(iobs)+i
         resid=dble(propmil(ii))-g(i)
         resid2=resid*resid
   9     obj=obj+resid2
      obj=(obj/ncart)**.5d0
      return
      end
c
c
      subroutine shareinit
c
c       this subroutine computes vinit for share so that it does not 
c       have to be recomputed repeatedly.
c
      parameter(ncars=10,ncarm1s=ncars-1,ncchars=80,nccharts=2,
     & nhouses=11,npolys=2,nobss=26000,nobsss=nobss*2,nbrs=23,nbr3s=
     & nbrs+3,ngrids=10,ngridp1s=ngrids+1)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension iaggv(nbr3s),itr(4),poly(4,ngridp1s),vex(3,2)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      data iaggv/25,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     & 22,23,0,25,26/
c
c       initialize.
c
      ngrid=10
      ngridp1=ngrid+1
      nmodelp1=nmodel+1
      nmodelp2=nmodel+2
      vex(1,1)=1.d20
      vex(1,2)=-1.d20
      do 9 i=2,3
         vex(i,1)=0.d0
   9     vex(i,2)=-1.d20
c
c       compute all values of v without error and find range.
c
      do 4 i=1,nobs
         ncart=ncar(i)
         do 2 j=1,ncart
c
c       construct car characteristics vector.
c
            ij=index(i)+j
            age=dble(float(icchar(ij,2)))
            agetr=age
            if(agetr.gt.5.)agetr=5.d0
            age=age/10.
            agetr=agetr/10.
            icchartr=iaggv(icchar(ij,1))
            ktm=nmodelp2+((icchartr-1)*2)+1
c
c       compute v without error.
c
   2        vinit(i,j)=alpha(icchartr)+(age*(alpha(nmodelp1)+
     &       alpha(ktm)))+(agetr*(alpha(nmodelp2)+alpha(ktm+1)))
c
c       order v.
c
         vor(1)=vinit(i,1)
         if(ncart.gt.1)then
            do 5 j=2,ncart
               jm1=j-1
               do 6 k=1,jm1
                  if(vinit(i,j).gt.vor(k))then
                     lt=j
                     do 7 l=k,jm1
                        lt=lt-1
   7                    vor(lt+1)=vor(lt)
                     vor(k)=vinit(i,j)
                     goto 5
                     endif
   6              continue
               vor(j)=vinit(i,j)
   5           continue
            endif
c
c       check for new extremes.
c
         ncart3=ncart
         if(ncart3.gt.3)ncart3=3
         if(vex(1,1).gt.vor(1))vex(1,1)=vor(1)
         if(vex(1,2).lt.vor(1))vex(1,2)=vor(1)
         if(ncart3.ge.2)then
            do 8 j=2,ncart3
               dvor=vor(j)-vor(j-1)
               if(vex(j,1).gt.dvor)vex(j,1)=dvor
               if(vex(j,2).lt.dvor)vex(j,2)=dvor
   8           continue
            endif
   4     continue
c
c       create grid of vor values.
c
      do 10 i=1,3
         vex(i,1)=vex(i,1)-(sigu*3.d0)
         vex(i,2)=vex(i,2)+(sigu*3.d0)
         if((i.gt.1).and.(vex(i,2).gt.0.))vex(i,2)=0.d0
         dvex=(vex(i,2)-vex(i,1))/ngrid
         vgrid(i,1)=vex(i,1)
         do 11 j=2,ngridp1
            jm1=j-1
  11        vgrid(i,j)=vgrid(i,jm1)+dvex
  10     continue
c
c       compute product of polynomials at each grid point.
c       compute polynomials.
c
      do 13 i=1,ngridp1
         poly(1,i)=1.d0
         do 12 j=2,4
            jm1=j-1
            poly(j,i)=0.d0
            vortt=1.d0
            do 14 k=1,npoly
               vortt=vortt*vgrid(jm1,i)
  14           poly(j,i)=poly(j,i)+(delta(jm1,k)*vortt)
  12        continue
  13     continue
c
c       multiply and add.
c
      do 15 i=1,ngridp1
         vgval1(i)=0.d0
         itr(1)=i
         itr(2)=i
         do 20 j=1,2
  20        vgval1(i)=vgval1(i)+((beta(1,j)+beta1adj(1,j))*
     &       poly(j,itr(j)))
         do 15 j=1,ngridp1
            vgval2(i,j)=0.d0
            itr(3)=j
            do 19 k=1,3
               do 19 l=k,3
  19              vgval2(i,j)=vgval2(i,j)+((beta(k,l)+beta2adj(k,l))*
     &             poly(k,itr(k))*poly(l,itr(l)))
            do 15 k=1,ngridp1
               itr(4)=k
               vgval3(i,j,k)=0.d0
               do 16 l=1,4
                  do 16 m=l,4
  16                 vgval3(i,j,k)=vgval3(i,j,k)+(beta(l,m)*
     &                poly(l,itr(l))*poly(m,itr(m)))
  15           continue
c
c       monotonize.
c
      dsmall=.001d0*dvex
      do 17 i=1,ngridp1
         ip1=i+1
         if(ip1.gt.ngridp1)ip1=ngridp1
         dvgv=vgval1(i)+dsmall
         if(vgval1(ip1).lt.dvgv)vgval1(ip1)=dvgv
         do 17 j=1,ngridp1
            jp1=j+1
            if(jp1.gt.ngridp1)jp1=ngridp1
            dvgv=vgval2(i,j)+dsmall
            if(vgval2(ip1,j).lt.dvgv)vgval2(ip1,j)=dvgv
            if(vgval2(i,jp1).lt.dvgv)vgval2(i,jp1)=dvgv
            do 17 k=1,ngridp1
               kp1=k+1
               if(kp1.gt.ngridp1)kp1=ngridp1
               dvgv=vgval3(i,j,k)+dsmall
               if(vgval3(ip1,j,k).lt.dvgv)vgval3(ip1,j,k)=dvgv
               if(vgval3(i,jp1,k).lt.dvgv)vgval3(i,jp1,k)=dvgv
               if(vgval3(i,j,kp1).lt.dvgv)vgval3(i,j,kp1)=dvgv
  17           continue
c
c       compute slopes and intercepts for extrapolation.
c
      do 25 i=1,2
         if(i.eq.1)then
            i2=2
            i1t=1
            endif
         if(i.eq.2)then
            i2=ngridp1
            i1t=ngridp1
            endif
         i1=i2-1
         slope1(i)=(vgval1(i2)-vgval1(i1))/(vgrid(1,i2)-vgrid(1,i1))
  25     aint1(i)=vgval1(i2)-(slope1(i)*vgrid(1,i2))
      slope2(1,1)=(vgval2(2,1)-vgval2(1,1))/(vgrid(1,2)-vgrid(1,1))
      slope2(1,2)=(vgval2(1,2)-vgval2(1,1))/(vgrid(2,2)-vgrid(2,1))
      slope2(2,1)=(vgval2(ngridp1,1)-vgval2(ngrid,1))/
     & (vgrid(1,ngridp1)-vgrid(1,ngrid))
      slope2(2,2)=(vgval2(ngridp1,2)-vgval2(ngridp1,1))/(vgrid(2,2)-
     & vgrid(2,1))
      slope2(3,1)=(vgval2(2,ngridp1)-vgval2(1,ngridp1))/(vgrid(1,2)-
     & vgrid(1,1))
      slope2(3,2)=(vgval2(1,ngridp1)-vgval2(1,ngrid))/(vgrid(2,ngridp1)
     & -vgrid(2,ngrid))
      slope2(4,1)=(vgval2(ngridp1,ngridp1)-vgval2(ngrid,ngridp1))/
     & (vgrid(1,ngridp1)-vgrid(1,ngrid))
      slope2(4,2)=(vgval2(ngridp1,ngridp1)-vgval2(ngridp1,ngrid))/
     & (vgrid(2,ngridp1)-vgrid(2,ngrid))
      aint2(1)=vgval2(1,1)-(slope2(1,1)*vgrid(1,1))
      aint2(2)=vgval2(ngridp1,1)-(slope2(2,1)*vgrid(1,ngridp1))
      aint2(3)=vgval2(1,ngridp1)-(slope2(3,1)*vgrid(1,1))
      aint2(4)=vgval2(ngridp1,ngridp1)-(slope2(4,1)*vgrid(1,ngridp1))
      ijk=0
      do 23 i=1,2
         i11=1
         i12=ngridp1
         do 23 j=1,2
            i21=1
            i22=ngridp1
            do 23 k=1,2
               i31=1
               i32=ngridp1
               ijk=ijk+1
               do 24 l=1,3
                  if(i.eq.1)then
                     if(l.eq.1)then
                        i12=2
                        j1=1
                        j2=2
                        endif
                     if(l.ne.1)i12=1
                     endif
                  if(i.eq.2)then
                     if(l.eq.1)then
                        i11=ngrid
                        j1=ngrid
                        j2=ngridp1
                        endif
                     if(l.ne.1)i11=ngridp1
                     endif
                  if(j.eq.1)then
                     if(l.eq.2)then
                        i22=2
                        j1=1
                        j2=2
                        endif
                     if(l.ne.2)i22=1
                     endif
                  if(j.eq.2)then
                     if(l.eq.2)then
                        i21=ngrid
                        j1=ngrid
                        j2=ngridp1
                        endif
                     if(l.ne.2)i21=ngridp1
                     endif
                  if(k.eq.1)then
                     if(l.eq.3)then
                        i32=2
                        j1=1
                        j2=2
                        endif
                     if(l.ne.3)i32=1
                     endif
                  if(k.eq.2)then
                     if(l.eq.3)then
                        i31=ngrid
                        j1=ngrid
                        j2=ngridp1
                        endif
                     if(l.ne.3)i31=ngridp1
                     endif
  24              slope3(ijk,l)=(vgval3(i12,i22,i32)-
     &             vgval3(i11,i21,i31))/(vgrid(l,j2)-vgrid(l,j1))
  23           continue
      return
      end
c
c
      subroutine sharenorm(ncart,uhat)
c
c       this subroutine norms the uhat vector when only shares are 
c       being used in estimation.
c
      parameter(ncars=10)
      implicit real*8(a-h,o-z)
      dimension uhat(ncars)
      uhat(ncart)=0.d0
      if(ncart.gt.1)then
         ncartm1=ncart-1
         do 2 i=1,ncartm1
   2        uhat(ncart)=uhat(ncart)-uhat(i)
         uhat(ncart)=uhat(ncart)/ncartm1
         do 3 i=1,ncartm1
   3        uhat(i)=uhat(i)+uhat(ncart)
         endif
      return
      end
c
c
      subroutine sharep(uhat,ncart,nuhat,propmiles)
c
c       this subroutine computes the shares for the relevant car for 
c       plotmiles.
c
      parameter(ncars=10,ncarm1s=ncars-1,ncchars=80,nccharts=2,
     & ngrids=10,ngridp1s=ngrids+1,nhouses=11,nobss=26000,
     & nobsss=nobss*2,npolys=2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension epsi(ncars),itrnsl(ncars),psi(ncars),uhat(ncars),
     & v(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      ncartm1=ncart-1
      if(ncartm1.eq.0)then
         nuhat=1
         vor(1)=vinit(iobs,1)+uhat(1)
         propmiles=1.d0
         return
         endif
c
c       compute v conditional on u.
c
      do 2 i=1,ncart
   2     v(i)=vinit(iobs,i)+uhat(i)
c
c       order v.
c
      vor(1)=v(1)
      itrnsl(1)=1
      do 3 i=2,ncart
         im1=i-1
         do 4 j=1,im1
            if(v(i).gt.vor(j))then
               kt=i
               do 5 k=j,im1
                  kt=kt-1
                  vor(kt+1)=vor(kt)
   5              itrnsl(kt+1)=itrnsl(kt)
               vor(j)=v(i)
               itrnsl(j)=i
               goto 3
               endif
   4        continue
         vor(i)=v(i)
         itrnsl(i)=i
   3     continue
c
c       compute psi.
c
      itr=itrnsl(ncart)
      psi(itr)=0.d0
      it=ncart
      do 6 i=2,ncart
         itp1=it
         it=it-1
         itr=itrnsl(it)
         itm=it
         if(itm.gt.ncarmax)itm=ncarmax
   6     psi(itr)=psi(itrnsl(itp1))+(omega(itm)*(vor(it)-vor(itp1)))
c
c       compute exp(psi) and denominator.
c
      nuhat=itrnsl(1)
      amxpsi=psi(nuhat)
      denom=0.d0
      do 7 i=1,ncart
         epsi(i)=exp(psi(i)-amxpsi)
   7     denom=denom+epsi(i)
c
c       compute g.
c
      propmiles=epsi(1)/denom
      return
      end
c
c
      subroutine shareres(uhat,ncartm1,resid,dresid,ifder)
c
c       this subroutine computes residuals for shares.
c
      parameter(ncars=10,ncarm1s=ncars-1,ncchars=80,nccharts=2,
     & ngrids=10,ngridp1s=ngrids+1,nhouses=11,npolys=2,nobss=26000,
     & nobsss=nobss*2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension damxpsi(ncars),ddenom(ncars),depsi(ncars,ncars),
     & dg(ncars,ncars),dpsi(ncars,ncars),dresid(ncars,ncars),
     & dv(ncars,ncars),dvor(ncars,ncars),epsi(ncars),g(ncars),
     & itrnsl(ncars),psi(ncars),resid(ncars),uhat(ncars),v(ncars)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/theta/alpha(ncchars),beta(4,4),beta1adj(4,4),
     & beta2adj(4,4),delta(3,npolys),gamma(nhouses),omega(ncarm1s),
     & sigu,ncchar,npoly
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
      ncart=ncartm1+1
c
c       compute v conditional on u.
c
      do 2 i=1,ncartm1
   2     v(i)=vinit(iobs,i)+uhat(i)
      v(ncart)=vinit(iobs,ncart)
      if(ifder.eq.1)then
         do 23 i=1,ncartm1
            do 24 j=1,ncartm1
  24           dv(i,j)=0.d0
  23        dv(i,i)=1.d0
         do 25 i=1,ncartm1
  25        dv(ncart,i)=0.d0
         endif
c
c       order v.
c
      vor(1)=v(1)
      if(ifder.eq.1)then
         do 22 i=1,ncartm1
  22        dvor(1,i)=dv(1,i)
         endif
      if(ncart.eq.1)return
      itrnsl(1)=1
      do 3 i=2,ncart
         im1=i-1
         do 4 j=1,im1
            if(v(i).gt.vor(j))then
               kt=i
               do 5 k=j,im1
                  kt=kt-1
                  ktp1=kt+1
                  vor(ktp1)=vor(kt)
                  if(ifder.eq.1)then
                     do 21 l=1,ncartm1
  21                    dvor(ktp1,l)=dvor(kt,l)
                     endif
   5              itrnsl(kt+1)=itrnsl(kt)
               vor(j)=v(i)
               if(ifder.eq.1)then
                  do 20 k=1,ncartm1
  20                 dvor(j,k)=dv(i,k)
                  endif
               itrnsl(j)=i
               goto 3
               endif
   4        continue
         vor(i)=v(i)
         if(ifder.eq.1)then
            do 19 j=1,ncartm1
  19           dvor(i,j)=dv(i,j)
            endif
         itrnsl(i)=i
   3     continue
c
c       compute psi.
c
      itr=itrnsl(ncart)
      psi(itr)=0.d0
      if(ifder.eq.1)then
         do 18 i=1,ncartm1
  18        dpsi(itr,i)=0.d0
         endif
      it=ncart
      do 6 i=2,ncart
         itp1=it
         it=it-1
         itr=itrnsl(it)
         itm=it
         if(itm.gt.ncarmax)itm=ncarmax
         psi(itr)=psi(itrnsl(itp1))+(omega(itm)*(vor(it)-vor(itp1)))
         if(ifder.eq.1)then
            do 17 j=1,ncartm1
  17           dpsi(itr,j)=dpsi(itrnsl(itp1),j)+(omega(itm)*(dvor(it,j)
     &          -dvor(itp1,j)))
            endif
   6     continue
c
c       compute exp(psi) and denominator.
c
      amxpsi=psi(itrnsl(1))
      denom=0.d0
      do 7 i=1,ncart
         epsi(i)=exp(psi(i)-amxpsi)
   7     denom=denom+epsi(i)
      if(ifder.eq.1)then
         do 16 i=1,ncartm1
            ddenom(i)=0.d0
  16        damxpsi(j)=dpsi(itrnsl(1),j)
         do 14 i=1,ncart
            do 15 j=1,ncartm1
               depsi(i,j)=epsi(i)*(dpsi(i,j)-damxpsi(j))
  15           ddenom(j)=ddenom(j)+depsi(i,j)
  14        continue
         endif
c
c       compute g.
c
      do 8 i=1,ncart
   8     g(i)=epsi(i)/denom
      if(ifder.eq.1)then
         do 12 i=1,ncart
            do 13 j=1,ncartm1
  13           dg(i,j)=(depsi(i,j)/denom)-(g(i)*ddenom(j)/denom)
  12        continue
         endif
c
c       compute residual, square, and add.
c
      do 9 i=1,ncart
         ii=index(iobs)+i
         if(propmil(ii).gt..9)then
            fred=2.
            endif
         if(propmil(ii).lt.(.1d0/ncart))then
            fred=3.
            endif
   9     resid(i)=dble(propmil(ii))-g(i)
      if(ifder.eq.1)then
         do 10 i=1,ncart
            ii=index(iobs)+i
            do 11 j=1,ncartm1
  11           dresid(i,j)=-dg(i,j)
  10        continue
         endif
      return
      end
c
c
      subroutine stairs(ncartm1,uhat,iconv)
c
c       this subroutine is an alternative optimization routine for 
c       share.
c
      parameter(ncars=10,ncarm1s=ncars-1,nccharts=2,nhouses=11,
     & nobss=26000,nobsss=nobss*2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension deltav(ncarm1s),iprobu(ncarm1s),resid(ncars),
     & uhat(ncars),uhold(ncars),uholdv(ncarm1s)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/sharestf/g(ncars)
      iterd=0
      niterd=25*ncartm1
      iconv=0
c
c       check for outlier uhat terms.
c
      do 9 i=1,ncartm1
         if(abs(uhat(i)).gt.10.)then
            obj=1.d20
            delta=uhat(i)/10.d0
            if(abs(delta).gt.5.)delta=5.d0*delta/abs(delta)
            uhold0=uhat(i)
            uhat(i)=(-1.d0)*delta
            do 10 j=1,11
               uhat(i)=uhat(i)+delta
               if(j.eq.11)uhat(i)=uhold0
               call share(uhat,ncartm1,objt)
               if(objt.lt.obj)then
                  obj=objt
                  uhold(i)=uhat(i)
                  endif
  10           continue
            uhat(i)=uhold(i)
            if(abs(uhat(i)-uhold0).gt.1.)then
               uhat(i)=uhat(i)-delta
               delta=delta/10.d0
               uhat(i)=uhat(i)-delta
               do 11 j=1,21
                  uhat(i)=uhat(i)+delta
                  call share(uhat,ncartm1,objt)
                  if(objt.lt.obj)then
                     obj=objt
                     uhold(i)=uhat(i)
                     endif
  11              continue
               uhat(i)=uhold(i)
               endif
            endif
   9     continue
      do 12 i=1,ncartm1
         if(abs(uhat(i)).lt.10.)goto 26
  12     continue
      delta=1.d20
      obj=1.d20
      do 13 i=1,ncartm1
         if(abs(uhat(i)).lt.abs(delta))delta=uhat(i)
  13     continue
      delta=delta/10.d0
      deltan=10.d0
      if(delta.gt.5.)then
         deltan=deltan*abs(delta)/5.d0
         delta=5.d0*delta/abs(delta)
         endif
      deltan=deltan+1.d0
      uhold0=uhat(1)
      do 14 i=1,ncartm1
  14     uhat(i)=uhat(i)-(deltan*delta)
      do 17 i=1,11
         do 15 j=1,ncartm1
  15        uhat(j)=uhat(j)+delta
         if(i.eq.11)then
            if(abs(uhat(1)-uhold0).gt..1)then
               udeladj=uhat(1)-uhold0
               do 25 j=1,ncartm1
  25              uhat(j)=uhat(j)+udeladj
               endif
            endif
         call share(uhat,ncartm1,objt)
         if(objt.lt.obj)then
            obj=objt
            do 16 j=1,ncartm1
  16           uhold(j)=uhat(j)
            endif
  17     continue
      do 18 i=1,ncartm1
  18     uhat(i)=uhold(i)
      if(abs(uhat(1)-uhold0).gt.1.)then
         do 19 i=1,ncartm1
  19        uhat(i)=uhat(i)-delta
         delta=delta/10.d0
         do 20 i=1,ncartm1
  20        uhat(i)=uhat(i)-delta
         do 21 i=1,21
            do 22 j=1,ncartm1
  22           uhat(j)=uhat(j)+delta
            call share(uhat,ncartm1,objt)
            if(objt.lt.obj)then
               obj=objt
               do 23 j=1,ncartm1
  23              uhold(j)=uhat(j)
               endif
  21        continue
         do 24 i=1,ncartm1
  24        uhat(i)=uhold(i)
         endif
  26  iflag=0 
      do 27 i=1,ncartm1
         iprobu(i)=0
         if(abs(uhat(i)).gt.10.)then
            iflag=1
            iprobu(i)=1
            endif
  27     continue
      if(iflag.eq.0)goto 4
      delmax=0.d0
      do 28 i=1,ncartm1
         if(iprobu(i).eq.1)then
            uholdv(i)=uhat(i)
            uhold(i)=uhat(i)
            deltav(i)=uhat(i)/10.d0
            if(abs(deltav(i)).gt.delmax)delmax=abs(deltav(i))
            endif
  28     continue
      if(delmax.gt.5.)then
         delmax=delmax/5.d0
         do 29 i=1,ncartm1
            if(iprobu(i).eq.1)deltav(i)=deltav(i)/delmax
  29        continue
         endif
      do 30 i=1,ncartm1
         if(iprobu(i).eq.1)uhat(i)=(-1.d0)*deltav(i)
  30     continue
      do 31 i=1,11
         if(i.lt.11)then
            do 32 j=1,ncartm1
               if(iprobu(j).eq.1)uhat(j)=uhat(j)+deltav(j)
  32           continue
            endif
         if(i.eq.11)then
            do 33 j=1,ncartm1
               if(iprobu(j).eq.1)uhat(j)=uholdv(j)
  33           continue
            endif
         call share(uhat,ncartm1,objt)
         if(objt.lt.obj)then
            do 34 j=1,ncartm1
               if(iprobu(j).eq.1)uhold(j)=uhat(j)
  34           continue
            endif
  31     continue
      do 35 i=1,ncartm1
         if(iprobu(i).eq.1)uhat(i)=uhold(i)
  35     continue
c
c       find direction.
c
   4  call share(uhat,ncartm1,obj)
      if(obj.lt..1d-2)then
         iconv=1
         return
         endif
      iterd=iterd+1
      if(iterd.gt.niterd)then
         iconv=0
         return
         endif
      ii=index(iobs)
      armax=0.d0
      ncart=ncartm1+1
      do 2 i=1,ncart
         ii=ii+1
         resid(i)=dble(propmil(ii))-g(i)
         aresid=abs(resid(i))
         if(aresid.gt.armax)then
            armax=aresid
            irmax=i
            endif
   2     continue
c
c       check for improvement.   
c
      if(resid(irmax).gt.0.)delta=.5d0
      if(resid(irmax).lt.0.)delta=-.5d0
      if(irmax.lt.ncart)then
         if(.5.lt.abs(.1d0*uhat(irmax)))delta=delta*abs(.1d0*
     &    uhat(irmax))/.5d0
         endif
      if(irmax.eq.ncart)then
         do 8 i=1,ncartm1
            if(abs(delta).lt.abs(.1d0*uhat(i)))delta=delta*
     &       abs(.1d0*uhat(i)/delta)
   8        continue
         endif
      itere=0
      iuflag=0
      idflag=0
   3  continue
      if(irmax.lt.ncart)then
         uhold(irmax)=uhat(irmax)
         uhat(irmax)=uhat(irmax)+delta
         endif
      if(irmax.eq.ncart)then
         do 5 i=1,ncartm1
            uhold(i)=uhat(i)
   5        uhat(i)=uhat(i)-delta
         endif
      itere=itere+1
      call share(uhat,ncartm1,objt)
      if(objt.lt..1d-2)then
         iconv=1
         return
         endif
      if(objt.le.obj)then
         if(idflag.eq.0)then
            iuflag=1
            obj=objt
            delta=delta*1.5d0
            if(itere.le.9)goto 3
            if(itere.gt.9)goto 4
            endif
         if(idflag.eq.1)then
            obj=objt
            goto 4
            endif
         endif
      if(objt.gt.obj)then
         if(iuflag.eq.1)then
            if(irmax.lt.ncart)uhat(irmax)=uhold(irmax)
            if(irmax.eq.ncart)then
               do 6 i=1,ncartm1
   6              uhat(i)=uhold(i)
               endif
            goto 4
            endif
         if(iuflag.eq.0)then
            if(itere.le.9)then
               delta=delta/2.d0
               if(irmax.lt.ncart)uhat(irmax)=uhold(irmax)
               if(irmax.eq.ncart)then
                  do 7 i=1,ncartm1
   7                 uhat(i)=uhold(i)
                  endif
               goto 3
               endif
            if(itere.gt.9)then
               if(obj.gt..01)iconv=0
               if(obj.lt..01)iconv=1
               return
               endif
            endif
         endif
      return
      end
c
c
      subroutine uhatconst1(ncart,uhat)
c
c       this subroutine computes uhat using an ameoba routine with some
c       adjustments.
c
      parameter(ncars=10,ncarm1s=ncars-1)
      implicit real*8(a-h,o-z)
      dimension dresid(ncars,ncars),obj(ncars),resid0(ncars),
     & resid1(ncars),simplex(ncars,ncarm1s),simpt(ncars),uhat(ncars),
     & uhatold(ncars)
      common/icoa/icoamo
      external nmsimp,share
c
c       initialize uhat.
c
      do 2 i=1,ncart
   2     uhat(i)=0.d0
c
c       minimize sum of squares using simplex.
c
      ncartm1=ncart-1
      if(ncart.gt.1)then
         do 3 i=1,ncartm1
            uhatold(i)=uhat(i)
   3        simplex(1,i)=uhat(i)
         call shareres(uhat,ncartm1,resid0,dresid,0)
         armin=1.d20
         do 21 i=1,ncart
            aresid0=abs(resid0(i))
            if(aresid0.lt.armin)then
               armin=aresid0
               irmin=i
               endif
  21        continue
         ip1=1
         do 4 i=1,ncart
            if(i.ne.irmin)then
               ip1=ip1+1
               do 6 j=1,ncartm1
   6              simplex(ip1,j)=simplex(1,j)
               if(resid0(i).lt.0.)stpr=-.5d0
               if(resid0(i).ge.0.)stpr=.5d0
               if(i.lt.ncart)then
                  if(.5.lt.abs(.1d0*simplex(ip1,i)))stpr=stpr*
     &             abs(.1d0*simplex(ip1,i))/.5d0
                  endif
               if(i.eq.ncart)then
                  do 26 j=1,ncartm1
                     if(abs(stpr).lt.abs(.1d0*simplex(ip1,j)))stpr=stpr*
     &                abs(.1d0*simplex(ip1,j)/stpr)
  26                 continue
                  endif
               iterres=0
  20           continue
               if(i.lt.ncart)simplex(ip1,i)=simplex(ip1,i)+stpr
               if(i.eq.ncart)then
                  do 22 j=1,ncartm1
  22                 simplex(ip1,j)=simplex(ip1,j)-stpr
                  endif
               do 19 j=1,ncartm1
  19              simpt(j)=simplex(ip1,j)
               simpt(ncart)=0.d0
               call shareres(simpt,ncartm1,resid1,dresid,0)
               resprod=resid1(i)*resid0(i)
               if((abs(resid1(i)).gt.abs(resid0(i))).and.
     &          (resprod.gt.0.))then
                  write(6,422)i,resid0(i),resid1(i)
 422              format(1x,'resid for ',i2,' going wrong way: ',g15.8,
     &             2x,g15.8)
                  stop
                  endif
               if(resprod.gt.0.)then
                  iterres=iterres+1
                  if(iterres.le.5)then
                     if(i.lt.ncart)simplex(ip1,i)=simplex(ip1,i)-stpr
                     if(i.eq.ncart)then
                        do 23 j=1,ncartm1
  23                       simplex(ip1,j)=simplex(ip1,j)+stpr
                        endif
                     stpr=stpr*2.d0
                     goto 20
                     endif
                  endif
               endif
   4        continue
         objold=1.d20
         do 8 i=1,ncart
            do 9 j=1,ncartm1
   9           simpt(j)=simplex(i,j)
            simpt(ncart)=0.d0
            call share(simpt,ncartm1,objt)
            if(objt.lt.objold)objold=objt
   8        obj(i)=objt   
         ftol=.1d-4
         ytol=.1d-5
         do 7 i=1,8
            icoamo=icoamo+1
            call amoeba(simplex,obj,ncartm1,ftol,share,iter,ibest,ytol)
            do 10 j=1,ncartm1
  10           uhat(j)=simplex(ibest,j)
            if(obj(ibest).lt.ftol)then
               call share(uhat,ncartm1,objt)
               return
               endif
            uhat2=0.d0
            do 11 j=1,ncartm1
               duhat=uhat(j)-uhatold(j)
  11           uhat2=uhat2+(duhat*duhat)
            uhat2=(uhat2/ncartm1)**.5d0
            dobj=abs(obj(ibest)-objold)/objold
            if((uhat2.lt..1d-2).and.(dobj.lt..1d-3))then
               call share(uhat,ncartm1,objt)
               return
               endif
            do 12 j=1,ncartm1
  12           uhatold(j)=uhat(j)
            objold=obj(ibest)
            do 13 j=1,ncartm1
               simplex(1,j)=uhat(j)
               do 13 k=2,ncart
  13              simplex(k,j)=uhat(j)
            call shareres(uhat,ncartm1,resid0,dresid,0)
            armin=1.d20
            do 24 j=1,ncart
               aresid0=abs(resid0(j))
               if(aresid0.lt.armin)then
                  armin=aresid0
                  irmin=j
                  endif
  24           continue
            jp1=1
            do 14 j=1,ncart
               if(j.ne.irmin)then
                  jp1=jp1+1
                  if(resid0(j).lt.0.)stpr=-.5d0
                  if(resid0(j).ge.0.)stpr=.5d0
                  if(j.lt.ncart)then
                     if(.5.lt.abs(.1d0*simplex(jp1,j)))stpr=stpr*
     &                abs(.1d0*simplex(jp1,j))/.5d0
                     endif
                  if(j.eq.ncart)then
                     do 27 k=1,ncartm1
                        if(abs(stpr).lt.abs(.1d0*simplex(jp1,k)))stpr=
     &                   stpr*abs(.1d0*simplex(jp1,k)/stpr)
  27                    continue
                     endif
                  iterres=0
  30              continue
                  if(j.lt.ncart)simplex(jp1,j)=simplex(1,j)+stpr
                  if(j.eq.ncart)then
                     do 25 k=1,ncartm1
  25                    simplex(jp1,k)=simplex(1,k)-stpr
                     endif
                  do 29 k=1,ncartm1
  29                 simpt(k)=simplex(jp1,k)
                  simpt(ncart)=0.d0
                  call shareres(simpt,ncartm1,resid1,dresid,0)
                  resprod=resid1(j)*resid0(j)
                  if((abs(resid1(j)).gt.abs(resid0(j))).and.
     &             (resprod.gt.0.))then
                     write(6,422)j,resid0(j),resid1(j)
                     stop
                     endif
                  if(resprod.gt.0.)then
                     iterres=iterres+1
                     if(iterres.le.5)then
                        stpr=stpr*2.d0
                        goto 30
                        endif
                     endif
                  endif
  14           continue
            do 15 j=1,ncart
               do 16 k=1,ncartm1
  16              simpt(k)=simplex(j,k)
               call share(simpt,ncartm1,objt)
  15           obj(j)=objt
   7        continue
         if(obj(1).gt..01)then
            call stairs(ncartm1,uhat,iconv)
            if(iconv.eq.0)then
               write(6,100)
 100           format(1x,'no convergence for share')
               endif
            endif
         endif
      call share(uhat,ncartm1,objt)
      return
      end
c
c
      subroutine uhatconst2(ncart,uhat,iconv)
c
c       this subroutine computes uhat using a gauss-newton routine.
c
      parameter(ncars=10,ncar2s=ncars*2,ngrids=10,ngridp1s=ngrids+1,
     & nobss=26000,nobsss=nobss*2,nhouses=11,nccharts=2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension delta(ncars),dresid(ncars,ncars),resid(ncars),
     & uhat(ncars),uhatold(ncars),work(ncars),work2(ncar2s)
      common/conoco/iconoco
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
      common/vini/aint1(2),aint2(4),slope1(2),slope2(4,2),
     & slope3(8,3),vgrid(3,ngridp1s),vgval1(ngridp1s),
     & vgval2(ngridp1s,ngridp1s),vgval3(ngridp1s,ngridp1s,ngridp1s),
     & vinit(nobss,ncars),vor(ncars),ngridp1
c
c       initialize.
c
      do 2 i=1,ncart
   2     uhat(i)=0.d0
      if(ncart.le.1)then
         call shareres(uhat,ncartm1,resid,dresid,ifder)
         iconv=1
         return
         endif
      ncartm1=ncart-1
      do 3 i=1,ncartm1
         uhat(i)=vinit(iobs,ncart)-vinit(iobs,i)
   3     uhatold(i)=uhat(i)
      tol=.001d0
      niter=1
c
c       evaluate objective function and check for convergence.
c
      ifder=0
      call shareres(uhat,ncartm1,resid,dresid,ifder)
      resid2=0.d0
      do 4 i=1,ncartm1
   4     resid2=resid2+(resid(i)*resid(i))
      resid2=resid2/ncartm1
      resid2=resid2**.5d0
      resid2old=resid2
      if(resid2.lt.tol)then
         iconv=1
         return
         endif
c
c       evaluate derivatives.
c
  14  ifder=1
      call shareres(uhat,ncartm1,resid,dresid,ifder)
c
c       compute delta.
c
      d1=-1.d0
      call linv3f(dresid,work,1,ncartm1,ncars,d1,d2,work2,ier)
      if(ier.gt.0)then
         write(6,100)ier
 100     format(1x,'ier = ',i5)
         stop
         endif
      do 5 i=1,ncartm1
         delta(i)=0.d0
         do 6 j=1,ncartm1
   6        delta(i)=delta(i)-(dresid(i,j)*resid(j))
   5     continue
c
c       normalize delta.
c
      delta2=0.d0
      do 7 i=1,ncartm1
   7     delta2=delta2+(delta(i)*delta(i))
      if(delta2.gt.1.)then
         delta2=delta2**.5d0
         do 8 i=1,ncartm1
   8        delta(i)=delta(i)/delta2
         endif
c
c       adjust uhat and check for improvement.
c
      do 9 i=1,ncartm1
   9     uhat(i)=uhat(i)+delta(i)
      ifder=0
      call shareres(uhat,ncartm1,resid,dresid,ifder)
      resid2=0.d0
      do 10 i=1,ncartm1
  10     resid2=resid2+(resid(i)*resid(i))
      resid2=resid2/ncartm1
      resid2=resid2**.5d0
      if(resid2.lt.tol)then
         iconv=1
         return
         endif
      if(resid2.lt.resid2old)then
         niterex=1
  13     resid2old=resid2
c
c       check for extension.
c
         do 11 i=1,ncartm1
            delta(i)=delta(i)/3.d0
  11        uhat(i)=uhat(i)+delta(i)
         call shareres(uhat,ncartm1,resid,dresid,ifder)
         resid2=0.d0
         do 12 i=1,ncartm1
  12        resid2=resid2+(resid(i)*resid(i))
         resid2=resid2/ncartm1
         resid2=resid2**.5d0
         if(resid2.lt.tol)then
            iconv=1
            return
            endif
         if(resid2.lt.resid2old)then
            niterex=niterex+1
            if(niterex.lt.5)goto 13
            niter=niter+1
            if(niter.lt.20)goto 14
            iconoco=iconoco+1
            if((iconoco.lt.10).or.(((iconoco/10000)*10000).eq.iconoco))
     &       write(6,101)iconoco
 101        format(1x,'no convergence in uhatconst2 ',i7,' times')
            iconv=0
            return
            endif
         if(resid2.ge.resid2old)then
            do 15 i=1,ncartm1
  15           uhat(i)=uhat(i)-delta(i)
            niter=niter+1
            if(niter.lt.20)goto 14
            iconoco=iconoco+1
            if((iconoco.lt.10).or.(((iconoco/10000)*10000).eq.iconoco))
     &       write(6,101)iconoco
            iconv=0
            return
            endif
         endif
c
c       no improvement.  take half-steps.
c
      if(resid2.ge.resid2old)then
         niterh=1
  18     continue
         do 16 i=1,ncartm1
            delta(i)=delta(i)/2.d0
  16        uhat(i)=uhat(i)-delta(i)
         call shareres(uhat,ncartm1,resid,dresid,ifder)
         resid2=0.d0
         do 17 i=1,ncartm1
  17        resid2=resid2+(resid(i)*resid(i))
         resid2=resid2/ncartm1
         resid2=resid2**.5d0
         if(resid2.lt.tol)then
            iconv=1
            return
            endif
         if(resid2.lt.resid2old)then
            resid2old=resid2
            niter=niter+1
            if(niter.lt.20)goto 14
            iconoco=iconoco+1
            if((iconoco.lt.10).or.(((iconoco/10000)*10000).eq.iconoco))
     &       write(6,101)iconoco
            iconv=0
            return
            endif
         if(resid2.ge.resid2old)then
            niterh=niterh+1
            if(niterh.lt.6)goto 18
            iconoco=iconoco+1
            if((iconoco.lt.10).or.(((iconoco/10000)*10000).eq.iconoco))
     &       write(6,101)iconoco
            iconv=0
            return
            endif
         endif
      end  
c
c
      subroutine utrunc(u)
c
c       this subroutine truncates uniform random numbers.
c
      implicit real*8(a-h,o-z)
      real big,small,u
      data big/.999999/
      data small/.000001/
      if(u.lt.small)u=small
      if(u.gt.big)u=big
      return
      end
c
c
      subroutine waldtest(icase,bhat,nx,cov)
c
c       this subroutine computes wald tests for the various ols 
c       specifications.
c
      parameter(nccharts=2,nbrs=23,nhouses=11,nobss=26000,nobsss=
     & nobss*2,nx1s=nbrs+3,nx3s=nx1s+nhouses,nx4s=nx3s+(2*nbrs)-1,
     & nx42s=nx4s*2,nx4ss=nx4s*(nx4s+1)/2)
      implicit real*8(a-h,o-z)
      real hchar,propmil,summiles
      dimension bhat(nx4s),cov(nx4s,nx4s),covhold(nx4ss),
     & covinv(nx4s,nx4s),eigval(nx4s),eigvec(nx4s,nx4s),work1(nx4s),
     & work2(nx42s)
      common/datax/hchar(nobss,nhouses),propmil(nobsss),
     & summiles(nobss),icchar(nobsss,nccharts),index(nobss),iobs,
     & ncar(nobss),ncarmax,nhouse,nmodel,nobs
c
c       initialize and invert covariance matrix.
c
      nbr=23
      anbr=dble(float(nbr))
      nx1=nbr+3
      nx2=nx1+(2*nbr)-1
      ij=0
      do 3 i=1,nx
         do 3 j=1,i
            ij=ij+1
            covinv(i,j)=cov(i,j)
            covinv(j,i)=cov(i,j)
   3        covhold(ij)=cov(i,j)/(cov(i,i)*cov(j,j))**.5d0
      d1=-1.d0
      call linv3f(covinv,work1,1,nx,nx4s,d1,d2,work2,ierl)
      call eigrs(covhold,nx,1,eigval,eigvec,nx4s,work1,ier)
      iflag=0
      do 4 i=1,nx
         if(eigval(i).le..1d-3)then
            if(iflag.eq.0)then
               write(6,100)
 100           format(1x,'problem eigenvectors:',/,1x,'#',3x,
     &          'eigenvalue',7x,'eigenvector')
               iflag=1
               endif
            write(6,101)i,eigval(i),(eigvec(j,i),j=1,nx1)
 101        format(1x,i2,g15.8,4(2x,g15.8),24(/,18x,4(2x,g15.8)))
            endif
   4     continue
      if(ierl.ne.0)stop
c
c       compute wald test for brand dummies for cases 1 and 2.
c
      if((icase.eq.1).or.(icase.eq.3))then
         ft=0.d0
         do 2 i=1,nbr
            it=i+3
            do 2 j=1,nbr
               jt=j+3
   2           ft=ft+(bhat(it)*covinv(it,jt)*bhat(jt))
         fnorm=(ft-anbr)/((2.d0*anbr)**.5d0)
         write(6,102)
 102     format(1x,'wald test for brand dummies:')
         write(6,103)ft,nbr,fnorm
 103     format(1x,'chi-square statistic: ',g15.8,/,1x,
     &    'degrees of freedom: ',i3,/,1x,'normalized: ',g15.8)
         endif
c
c       compute wald test for household characteristics.
c
      if((icase.eq.3).or.(icase.eq.4))then
         if(icase.eq.3)iad=nx1
         if(icase.eq.4)iad=nx2
         ft=0.d0
         do 5 i=1,nhouse
            it=i+iad
            do 5 j=1,nhouse
               jt=j+iad
   5           ft=ft+(bhat(it)*covinv(it,jt)*bhat(jt))
         anhouse=dble(float(nhouse))
         fnorm=(ft-anhouse)/((2.d0*anhouse)**.5d0)
         write(6,104)
 104     format(1x,'wald test for household characteristics:')
         write(6,103)ft,nhouse,fnorm
         endif
c
c       compute wald test for interaction of brand with age.
c
      if((icase.eq.2).or.(icase.eq.4))then
         nbr2=nbr*2
         nx1m1=nx1-1
         ft=0.d0
         do 6 i=1,nbr2
            it=i+nx1m1
            do 6 j=1,nbr2
               jt=j+nx1m1
   6           ft=ft+(bhat(it)*covinv(it,jt)*bhat(jt))
         anbr2=dble(float(nbr2))
         fnorm=(ft-anbr2)/((2.d0*anbr2)**.5d0)
         write(6,105)
 105     format(1x,'wald test for interaction of brand with age:')
         write(6,103)ft,nbr2,fnorm
         endif
      return
      end
